flatutils.pas

comerose_flatstyle_v4.42.9.0_d7.rar

      PolyLine([TopRight, BottomRight, BottomLeft]);
    end;
  end;
begin
  Canvas.Pen.Width := 1;
  Dec(Rect.Bottom);
  Dec(Rect.Right);
  while Width > 0 do begin
    Dec(Width);
    DoRect;
    InflateRect(Rect, -1, -1);
  end;
  Inc(Rect.Bottom);
  Inc(Rect.Right);
end;

function  DrawViewBorder(ViewBorder: TBorderAttrib;const oVal:Byte=1):TColor;
var         
  R: TRect;
  memBmp:TControlCanvas;
begin
  memBmp:=TControlCanvas.Create;
  try
   with ViewBorder do
   begin
    memBmp.Handle := GetWindowDC(Ctrl.Handle);
    GetWindowRect(Ctrl.Handle, R);
    OffsetRect(R, -R.Left, -R.Top);
    if (not(csDesigning in DesignState) and (FocusState or MouseState)) then
    begin
      result := FocusColor;
    end
    else
    begin
      result := FlatColor;
    end;
    dec(r.Left,   oVal);
    dec(r.Top,    oVal);
    inc(r.Right,  oVal);
    inc(r.Bottom, oVal);
    InflateRect(R, -oVal, -oVal);
    DrawButtonBorder(memBmp, R, BorderColor, oVal);
   end;
  finally
    memBmp.FreeHandle;
    memBmp.Free;
  end;
end;

function  GetParamValue(Var Value:String; Param:String):String;
var
  FontS, FontL, Spliter : Integer;
  SubValue:String;
  function Find(Value:String;cur:Integer):integer;
  var inx:integer;
  begin
    result := cur;
    for inx := Cur to Length(Value) do
       if Value[inx]=']' then
       begin
          result := inx;
          exit;
       end;
  end;
begin
  if Pos(Param,Value) > 0 then
  begin
     FontS     := Pos(Param,Value);
     FontL     := FontS + Length(Param);
     Spliter   := Find(Value,FontS);
     Result    := Trim(Copy(Value,FontL,Spliter-FontL));
     SubValue  := format('%s%s]',[Param,Result]);
     Delete(Value,Pos(SubValue,Value),Length(SubValue));
  end else begin
     Result := '';
  end;
end;

function  GetParamStyle(Value:String): TFontStyles;
begin
 Result := [];
 if (Pos('BOLD', Value) > 0)or(Pos('0', Value)>0) then
    result := Result + [fsBold];
 if (Pos('ITALIC', Value) > 0)or(Pos('1', Value)>0) then
    result := Result + [fsItalic];
 if (Pos('UNDERLINE', Value) > 0)or(Pos('2', Value)>0) then
    result := Result + [fsUnderline];
 if (Pos('STRIKEOUT', Value) > 0)or(Pos('3', Value)>0) then
    result := Result + [fsStrikeOut];
end;

function  GetParamPitch(Value:String): TFontPitch;
begin
 Result := fpDefault;
 if (Pos('VARIABLE', Value) > 0)or(Pos('1', Value)>0) then
    result := fpVariable;
 if (Pos('Fixed', Value) > 0)or(Pos('2', Value)>0) then
    result := fpFixed;
end;

function  GetParamDraw3D(Value:String): Boolean;
begin
 Result := False;
 if (Pos('True', Value) > 0)or(Pos('1', Value)>0) then
    result := True;
end;

function  GetParamColor(Value:String):TColor;
var
   inx : Word;
   State: Boolean;
begin
   for inx := Low(WaterColor) to High(WaterColor) do
   begin
    State := UpperCase(WaterColor[inx].enName) = UpperCase(Value);
    if State then
    begin
       result := WaterColor[inx].Value;
       exit;
    end;
   end;
   if not State then
      result := TColor(StrToInt(Value))
   else
      Result := clBlack;
end;

function  GetParamAlign(Value:String):TWaterAlign;
begin
  result := wpCenter;
  if (Pos('ALIGN', Value) > 0)or(Pos('0', Value)>0) then
      result := wpLeft;
  if (Pos('ALIGN', Value) > 0)or(Pos('2', Value)>0) then
      result := wpRight;
end;

procedure GetTitleParam(Var Font: TOtherParam; Var Title:String);
var
  Value, Param:String;
  FontS,FontE,Inx:Integer;
begin
 Value := Title;
 FontS := Pos(UpperCase(TitleStart), UpperCase(Value));
 FontE := Pos(UpperCase(TitleEnd), UpperCase(Value));
 Inx   := FontS + Length(TitleStart);
 Title := Copy(Value, Inx, FontE - Length(TitleEnd));
 if (FontS > 0) and (FontE > 0) then
 begin
    Inx   := FontE + Length(TitleEnd);
    Value := UpperCase(Copy(Value, Inx, Length(Value)));
    //解析 字体的大小
    Param := GetParamValue(Value, UpperCase(TitleSize));
    if Param <> '' then
       Font.Size  := StrToInt(Param)
    else
       Font.Size  := 8;
    //解析 字体的名称
    Param   := GetParamValue(Value, UpperCase(TitleName));
    if Param <> '' then
       Font.Name  := Param
    else
       Font.Name  := 'MS Sans Serif';
    //解析 字体的样式
    Param  := GetParamValue(Value, UpperCase(TitleStyle));
    if Param <> '' then
       Font.Style := GetParamStyle(Param)
    else
       Font.Style := [];
    //解析 字体的颜色
    Param  := GetParamValue(Value, UpperCase(TitleColor));
    if Param <> '' then
       Font.Color := GetParamColor(Param)
    else
       Font.Color := clWindowText;
    //解析 行距
    Param  := GetParamValue(Value, UpperCase(TitleLow));
    if Param <> '' then
       Font.Row := StrToInt(Param)
    else
       Font.Row := 0;
    Param  := GetParamValue(Value, UpperCase(TitlePitch));
    if Param <> '' then
       Font.Pitch := GetParamPitch(Param)
    else
       Font.Pitch := fpDefault;
    Param  := GetParamValue(Value, UpperCase(TitleDraw3D));
    if Param <> '' then
       Font.Draw3D := GetParamDraw3D(Param)
    else
       Font.Draw3D := False;
    Param  := GetParamValue(Value, UpperCase(TitleAlign));
    if Param <> '' then
       Font.Align  := GetParamAlign(Param)
    else
       Font.Align  := wpCenter;
 end else begin
    Title := '';
 end;
end;

procedure SetEditRect(Handle:HWnd; ClientWidth,ClientHeight,Width:Integer);
var
  Loc: TRect;
begin
  SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc));
  Loc := Rect(0, 0, ClientWidth - Width - 3, ClientHeight);
  SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
  SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc));
end;

procedure RemoveList(List:TList; State:TListState=lsClear);
var inx:integer;
begin
 //NO.1 free all the memory pointer
 for inx:=0 to List.Count - 1 do
     Dispose(List.Items[inx]);
 //NO.2 user select lsClear or lsFree to List;
 case State of
   lsClear : List.Clear;
   lsFree  : List.Free;
 end;
end;

procedure IPEmpty(Var IP:TIP);
begin
 IP.NO1 := ' 0 ';
 IP.NO2 := ' 0 ';
 IP.NO3 := ' 0 ';
 IP.NO4 := ' 0 ';
end;

procedure IPValue(Var IP:TIP;Inx:Word;Value:TIPChar);
begin
  case inx of
    1:IP.NO1 := Value;
    2:IP.NO2 := Value;
    3:IP.NO3 := Value;
    4:IP.NO4 := Value;
  end
end;

procedure CorrectTextbyWidth(C: TCanvas; var S: String; W: Integer);
var
  j: Integer;
begin
  j := Length(S);
  with C do
  begin
    if TextWidth(S) > w
    then
      begin
        repeat
          Delete(S, j, 1);
          Dec(j);
        until (TextWidth(S + '...') <= w) or (S = '');
        S := S + '...';
      end;
  end;
end;

function RectToCenter(var R: TRect; Bounds: TRect): TRect;
var
  OffsetLeft,OffsetTop:Integer;
begin
  OffSetLeft := (RectWidth(Bounds) - RectWidth(R)) div 2;
  OffsetTop  := (RectHeight(Bounds) - RectHeight(R)) div 2;
  OffsetRect(R, -R.Left, -R.Top);
  OffsetRect(R, OffsetLeft, OffsetTop);
  OffsetRect(R, Bounds.Left, Bounds.Top);
  Result := R;
end;

function RectWidth(R: TRect): Integer;
begin
  Result := R.Right - R.Left;
end;

function RectHeight(R: TRect): Integer;
begin
  Result := R.Bottom - R.Top;
end;

function  CheckValue(Value,MaxValue,MinValue: LongInt): LongInt;
begin
  Result := Value;
  if (MaxValue <> MinValue) then
  begin
    if Value < MinValue then
       Result := MinValue
    else
      if Value > MaxValue then
         Result := MaxValue;
  end;
end;

procedure FlatDrawText(Canvas: TCanvas; Enabled: Boolean; Caption: TCaption; DrawRect:TRect; Format:uint);
begin
 with Canvas do begin
  brush.style := bsClear;
  InflateRect(DrawRect, -4, 0);
  if Enabled then begin
     DrawText(Handle, PChar(Caption), Length(Caption), DrawRect, Format);
  end else begin
     OffsetRect(DrawRect, 1, 1);
     Font.Color := clBtnHighlight;
     DrawText(Handle, PChar(Caption), Length(Caption), DrawRect, Format);
     OffsetRect(DrawRect, -1, -1);
     Font.Color := clBtnShadow;
     DrawText(Handle, PChar(Caption), Length(Caption), DrawRect, Format);
  end;
  InflateRect(DrawRect, +4, 0);
 end;
end;

procedure DrawBitmap(Canvas:TCanvas; DrawRect:TRect; Source:TBitmap);
begin
 Canvas.StretchDraw(DrawRect, Source);
end;

procedure BoxDrawBackdrop(Canvas:TCanvas;ColorStart,ColorStop:TColor;Style:TStyleOrien;
                          ClientRect:TRect;ItemColor:TColor;Face:TStyleFace);
begin
 if Face = fsDefault then begin
    canvas.Brush.Color := ItemColor;
    canvas.FillRect(ClientRect);
 end else begin
    DrawBackdrop(canvas,ColorStart,ColorStop,ClientRect,Style)
 end;
end;

procedure GetBarPosition(ClientRect:TRect;TitleHas:boolean;TitlePosition:TTitlePosition;
                         Var BarsRect:TBarsRect; TitleHeight, BarHeight:Integer);
begin
  with BarsRect do begin
    prevRect := ClientRect;
    downRect := ClientRect;
    if TitleHas then begin
       case TitlePosition of
        tsTop :begin
         prevRect.Top    := prevRect.Top    + TitleHeight;
         prevRect.Bottom := prevRect.Top    + BarHeight;
         downRect.Top    := downRect.Bottom - BarHeight;
        end;
        tsBottom:begin
         prevRect.Bottom := prevRect.Top + BarHeight;
         downRect.Bottom := downRect.Bottom - TitleHeight;
         downRect.Top    := downRect.Bottom - BarHeight;
        end;
       end;
    end else begin
         prevRect.Bottom := prevRect.Top    + BarHeight;
         downRect.Top    := downRect.Bottom - BarHeight;
    end;
  end;
end;

function Max(const A, B: Integer): Integer;
begin
  if A > B then
     Result := A
  else
     Result := B;
end;

procedure DrawCheckBox(BoxRect:TRect; Position:TCheckPosition; Size:Integer; Var CheckRect:TRect);
var
  RectPos:TPoint;
  xLeft,yTop,y:integer;
begin
  y := (BoxRect.Bottom - BoxRect.Top - Size) div 2;
  if Position = bpLeft then begin
     RectPos   := Point(BoxRect.Left, BoxRect.Top);
     CheckRect := Rect(RectPos.x +  3, RectPos.y + y, RectPos.x + Size, RectPos.y + Size + y);
  end else begin
     RectPos   := Point(BoxRect.Right, BoxRect.Top);
     CheckRect := Rect(RectPos.x - Size - 3 , RectPos.y + y, RectPos.x - Size-  6, RectPos.y + Size + y);
  end;
  xLeft := CheckRect.Bottom-CheckRect.Top;
  yTop  := CheckRect.Right -CheckRect.Left;
  CheckRect.Right := CheckRect.Left + Max(xLeft,yTop);
end;


procedure GetStyleText(Value:TAlignmentText; var Result:UINT);
begin
  case Value of
   stLeft   : result := DT_LEFT   or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
   stRight  : result := DT_RIGHT  or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
   stCenter : result := DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
  end;
end;

procedure GetCheckBoxPosition(Value:TCheckPosition; var Result:UINT);
begin
  case Value of
   bpLeft   : result := DT_LEFT   or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
   bpRight  : result := DT_RIGHT  or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
  end;
end;

procedure SetTicketPoint(Value:TTicketPosition;Self,Ticket:TControl;TicketSpace:Integer);
var result : TPoint;
begin
  case Value of
    poTop:    result := Point(Self.Left, Self.Top - Ticket.Height - TicketSpace);
    poBottom: result := Point(Self.Left, Self.Top + Self.Height + TicketSpace);
    poLeft :  result := Point(Self.Left - Ticket.Width - TicketSpace, Self.Top + ((Self.Height - Ticket.Height) div 2));
    poRight:  result := Point(Self.Left + Self.Width + TicketSpace, Self.Top + ((Self.Height - Ticket.Height) div 2));
  end;
  Ticket.SetBounds(result.x, result.y, Ticket.Width, Ticket.Height);
end;

procedure DrawFocusRect(Canvas:TCanvas;FocusRect:TRect;Height:Integer);
begin
  FocusRect := Rect(FocusRect.left + 2, FocusRect.top + 2, FocusRect.Right - 2, FocusRect.top + Height - 2);
  Canvas.DrawFocusRect(FocusRect);
end;

function IndexInCount(Index,Count:Integer):boolean;
begin
  result := (Index >= 0) and (Index < Count);
end;

procedure DrawBackdrop(Canvas:TCanvas; StartColor, StopColor: TColor; CanRect:TRect;Style:TStyleOrien);
   var
      iCounter, iBuffer, iFillStep: integer;
      bR1, bG1, bB1, bR2, bG2, bB2: byte;
      aColor1, aColor2: LongInt;
      dCurR, dCurG, dCurB, dRStep, dGStep, dBStep: double;
      iDrawLen, iDrawPos: integer;
      rCans : TRect;
      iLeft, iTop, iRight, iBottom: integer;
begin
      iLeft     := CanRect.Left;
      iTop      := CanRect.Top;
      iRight    := CanRect.Right;
      iBottom   := CanRect.Bottom;

      aColor1   := ColorToRGB(StartColor);
      bR1       := GetRValue(aColor1);
      bG1       := GetGValue(aColor1);
      bB1       := GetBValue(aColor1);

      aColor2   := ColorToRGB(StopColor);
      bR2       := GetRValue(aColor2);
      bG2       := GetGValue(aColor2);
      bB2       := GetBValue(aColor2);

      dCurR     := bR1;
      dCurG     := bG1;
      dCurB     := bB1;

      dRStep    := (bR2-bR1) / 31;
      dGStep    := (bG2-bG1) / 31;
      dBStep    := (bB2-bB1) / 31;

      if Style = bsHorizontal then
         iDrawLen := (iRight - iLeft)
      else
         iDrawLen := (iBottom - iTop);

      iFillStep  := (iDrawLen div 31) + 1;

      for iCounter := 0 to 31 do begin
          iBuffer            := iCounter * iDrawLen div 31;
          Canvas.Brush.Color := RGB(trunc(dCurR), trunc(dCurG), trunc(dCurB));
          dCurR              := dCurR + dRStep;
          dCurG              := dCurG + dGStep;
          dCurB              := dCurB + dBStep;
          if Style = bsHorizontal then begin
             iDrawPos    := iLeft + iBuffer + iFillStep;
             if iDrawPos > iRight then iDrawPos := iRight;
             rCans    := Rect(iLeft + iBuffer, iTop, iDrawPos, iBottom);
          end else begin
             iDrawPos := iTop + iBuffer + iFillStep;
             if iDrawPos > iBottom then iDrawPos := iBottom;
             rCans    := Rect(iLeft, iTop + iBuffer, iRight, iDrawPos);
          end;
          Canvas.FillRect(rCans);
      end;
end;

procedure DrawTransBitBlt(Cnv: TCanvas; x, y: Integer; Bmp: TBitmap; clTransparent: TColor);
var
  bmpXOR, bmpAND, bmpINV, bmpTAG: TBitmap;
  oldcol: Longint;
begin
  bmpAND    := TBitmap.Create;
  bmpINV    := TBitmap.Create;
  bmpXOR    := TBitmap.Create;
  bmpTAG := TBitmap.Create;
  try
    bmpAND.Width      := Bmp.Width;