Procedure y Funcion nuevos DrwGradientLine y LabLinea

[[José Luis Garcí]]

Hola Compañeros Como siempre os pongo dos trozos de códigos nuevo, un procedure que dibuja una linea gradient y una funcion que hice para crear separaciones, espero os sirvan de ayuda

Código Delphi [-]
procedure DrawGradientLine(bCanvas:
TCanvas; X, Y, Width,height: integer;
StartColor, EndColor: TColor;Parejo:boolean);
//------------------------------------------------------------------------------
//****************************************************[ DRAWGRADIENTLINE ]******
//  Bajado originalmente de codeunivers.com/…/draw_gradient_line
//  Modificado por mi, se añade  la posibilidad de ancho y de si estilo continuo
//  21/08/2011           JLGT
//------------------------------------------------------------------------------
//  bCanvas     Canvas sobre el qiue dibujar la linea
//  X           Posición left a comenzar
//  Y           Posición Top a cpmenzar
//  Width       Ancho de la linea
//  Hight       Alto de la linea  (Mia)
//  StarColor   Color de inicio
//  EndColor    Color Final
//  Parejo      Si es truedibuja todas las lineas empezando igual,
//              si es false cada inicio de linea incrementa 1 desplazandose los colores 
//              diagonalmente (Mia)
//--------------------------------------------------------------EJEMPLO---------
//   Form1.DoubleBuffered:=True;
//   DrawGradientLine(Form1.Canvas,0,0,Form1.Width,5,clRed,clLime,True);
//   DrawGradientLine(Form1.Canvas,0,Form1.Height-43,Form1.Width,5,clRed,clLime,True);
//   DrawGradientLine(Form1.Canvas,0,0,50,Form1.Height,clBlack,clRed,True);
//   DrawGradientLine(Form1.Canvas,Form1.Width-66,0,50,Form1.Height,clLime,clBlack,True);
//------------------------------------------------------------------------------
var
fX,hy:integer;
dr,dg,db:Extended;
C1,C2:TColor;
r1,r2,g1,g2,b1,b2:Byte;
R,G,B:Byte;
cnt:integer;
begin
  if Parejo=False then  cnt:=0;
  for HY := y to y+height - 1 do
  begin
    if Parejo=True then cnt := 0;
    C1 := StartColor;
    C2 := EndColor;
    R1 := GetRValue(C1) ;
    G1 := GetGValue(C1) ;
    B1 := GetBValue(C1) ;
    R2 := GetRValue(C2) ;
    G2 := GetGValue(C2) ;
    B2 := GetBValue(C2) ;
    dr := (R2-R1) / Width;
    dg := (G2-G1) / Width;
    db := (B2-B1) / Width;
    for fX := X to X + Width - 1 do
    begin
      R := R1+Ceil(dr*cnt) ;
      G := G1+Ceil(dg*cnt) ;
      B := B1+Ceil(db*cnt) ;
      bCanvas.Pixels[fX, hy] := RGB(R,G,B);
      inc(cnt);
    end;
  end;
end;

function TForm1.LabLinea(Cap,Carc:string;Ali:TAlignment;Whi:Integer):string;
//------------------------------------------------------------------------------
//************************************************************[ LabLinea ]******
//  Función propia  JLGT 20/08/2011
//  texto con relleno a elejir posicion, para separaciones
//------------------------------------------------------------------------------
//  Cap   Cadena de Texto
//  Car   Caracter
//  Ali   taLeftJustify   cadena a la izquierda, Relleno a la derecha
//        taRightJustify  cadena a la derecha, Relleno a la izquierda
//        taCenter        cadena al centro, relleno a ambos lados
//  Whi
//---------------------------------------------------------------EJEMPLO--------
//
//  Label1.Caption:=LabLinea('Opciones',' ',taCenter,200);
//
//  Si el Label1 Cambiamos las caracteristicas del Font a negrita y subrallado,
//  queda un curios separador
//------------------------------------------------------------------------------

var VarIAnc,VariDif:Integer;
    VarSCad:string;
    lab:TLabel;
begin
    lab:=TLabel.Create(Self);
    lab.Parent:=Self;
    VarIAnc:=lab.Canvas.TextWidth(Cap);
    VariDif:=whi-VarIAnc;
    VarSCad:=Cap;
    case Ali of
      taLeftJustify: begin
                        while lab.Canvas.TextWidth(VarSCad) < Whi do  VarSCad:=VarSCad+Carc;
                     end;
      taRightJustify:begin
                        while lab.Canvas.TextWidth(VarSCad)  < Whi do  VarSCad:=Carc+VarSCad;
                     end;
      taCenter:begin
                        while lab.Canvas.TextWidth(VarSCad) < lab.Canvas.TextWidth(Cap)+(VariDif/2) do  VarSCad:=VarSCad+Carc;
                        while lab.Canvas.TextWidth(VarSCad) < whi do  VarSCad:=Carc+VarSCad
               end;
    end;
   Result:=VarSCad
end;

[[fjcg02]]

Hola José Luis,
he probado la función LabLinea y si pones el carácter de relleno cadana vacía '' la función se cuaja, ya que imagino que no se incrementa la longitud en caracteres, por lo que se bucla. Sería conveniente que controlaras que cuando el caracter sea '' lo conviertas en ' '.

Un saludo
PD: Respecto a lo que comentamos en su día, espero tener preparado un prototipo esta misma semana para pasártelo y que lo analices. Después lo publicaríamos en el Club.

[[José Luis Garcí]]

Gracias Javi, lo comprobare, ya que no probé con caracteres en vació, tranquilo, ahora mismo estoy peleándome con mi programa CreaTablas, espero estés pasando un buen mes de Agosto