delphi es letra comprueba que un campo sea letra o numero

procedure TusuarioN.Button1Click(Sender: TObject);
var
aux, abc:string;
i: integer;
correcto: boolean;
begin


 //el usuario solo puede tener letras y/o numeros
 abc:='1234567890qwertyuiopasdfghjklzxcvbnm'+'QWERTYUIOPASDFGHJKLZXCVBNM';

  aux:=edit1.Text;
  correcto:=true;
  for i := 1 to Length(aux) do
  begin

    if AnsiPos(aux[i],abc)=0 then
    begin
      correcto:=false;
    end;

  end;

  if correcto=false then
  begin
    ShowMessage('Usuario solo puede contener letras y/o numeros');
    exit;
  end;




(...)

delphi evitar que mi aplicacion se abra 2 veces en el mismo pc

procedure TForm1.FormCreate(Sender: TObject);
begin

 //***** evita que se abra 2 veces el programa
 CreateMutex(nil, False, 'MyAppId');
 if GetLastError <> 0 then Halt;

end;





.
 

encriptar y desencriptar

uses Math

    function encriptar(dato:string):string;
    function desencriptar(dato:string):string;


//*********************************************
function TclientesN.encriptar(dato:string):string;
var
  myNum : Byte;
  i: integer;
  tam: integer;
  aux:string;
begin

 tam:=Length(dato);

 for i:=1 to Length(dato) do
 begin

   myNum := Ord(dato[i]);
   myNum:=myNum + 1;
   dato[i]:=Chr(myNum);
   aux:=aux+Chr(myNum)+ Chr(RandomRange(65,90))+ Chr(RandomRange(97,122));

 end;

 result:=aux;

end;


//*********************************************
function TclientesN.desencriptar(dato:string):string;
var
  myNum : Byte;
  i,j: integer;
  tam: integer;
  aux:string;
begin

 tam:=(Length(dato) div 3);

 j:=0;
 for i:=1 to Length(dato) do
 begin

    j:=j+1;

    if j=1 then
    begin
      myNum := Ord(dato[i]);
      myNum:=myNum - 1;
      dato[i]:=Chr(myNum);
      aux:=aux+Chr(myNum);
    end;

    if j=3 then
    begin
      j:=0;
    end;

 end;

 result:=aux;

end;

Delphi Hilos de ejecución ejemplo

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls;



type
  TForm1 = class(TForm)
    BtnConHilo: TButton;
    ProgressBar1: TProgressBar;
    BtnSinHilo: TButton;
    procedure BtnConHiloClick(Sender: TObject);
    procedure BtnSinHiloClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses unit2;


{$R *.dfm}

//****************************************************************
procedure TForm1.BtnConHiloClick(Sender: TObject);
var
hilo: TProgreso;
begin

hilo:= TProgreso.Create(true);
hilo.FreeOnTerminate:=true;
hilo.Resume;

end;

//****************************************************************
procedure TForm1.BtnSinHiloClick(Sender: TObject);
begin
    ProgressBar1.Position:=0;

    repeat
      sleep(1000);
      ProgressBar1.Position:=ProgressBar1.Position +1;
    until
      ProgressBar1.Position = ProgressBar1.Max;
end;

end.



################################
unit2.pas
################################

unit Unit2;

interface
uses
 Classes, windows, unit1;

type
 TProgreso = class (TThread)
   protected
   procedure Execute; override;
 end;

implementation

//****************************************************************
procedure TProgreso.Execute;
begin

  inherited;

  with form1 do
  begin
    ProgressBar1.Position:=0;

    repeat
      sleep(1000);
      ProgressBar1.Position:=ProgressBar1.Position +1;
    until
      ProgressBar1.Position = ProgressBar1.Max;
  end;

end;

end.







.

delphi saber el dia de la semana

uses DateUtils

(...)

var
diaSemana: integer;
begin

diaSemana:=DayOfWeek(now);
showmessage(inttostr(diaSemana));


(...)






.

configurar Rave Report delphi informes

componente RvProject1
---------------------------
parametro Engine -> RvSystem1
parametro ProjectFile -> C:\bases\prueba.rav


componente RvSystem1
---------------------------
DefaultDest -> rdPrinter
SystemPrinter -> Copies -> 1  // numero de copias
SystemPrinter -> Title -> Titulo de la impresion

SystemSetups -> ssAllowSetup -> false   // para imprimir directamente


componente RvNDRWriter1
---------------------------



uses (...), inifiles;

(...)

procedure TForm1.Button1Click(Sender: TObject);
var
ini: TIniFile;
nombreImpresora: string;
begin

  ini := TIniFile.Create('./parametros.ini');
  nombreImpresora:=ini.ReadString('parametros', 'impresora', '');
  ini.Free;

  if nombreImpresora='' then
  begin    ShowMessage('Error al leer el fichero PARAMETROS.INI');
    exit;
  end;

  RvProject1.Open;
  if RvNDRWriter1.SelectPrinter(nombreImpresora)=false then
  begin
    ShowMessage('No exite impresora');
  end
  else
  begin
    RvProject1.Execute;
    RvProject1.Close;
  end;


end;






.

delphi cambiar el order del tab de los componentes tabulador

Botón derecho en el formulario -> Tab Order





.

ficheros ini fichero archivo archivos

uses inifiles;


//********************************************
procedure Tinicio.FormCreate(Sender: TObject);
var
ini: TIniFile;

(...)

    ini := TIniFile.Create('./parametros.ini');
    aux:=ini.ReadString('parametros', 'avisoanyonuevo', 'si');
    ini.Free;


(...)


    ini := TIniFile.Create('./parametros.ini');
    ini.WriteString('parametros', 'avisoanyonuevo', 'si');
    ini.Free;




.

cambio horario saber dia de la semana saber numero del mes

uses DateUtils;

(...)

//******************************************
procedure TForm1.Button1Click(Sender: TObject);
var
diadelasemana: integer;
numerodemes: integer;
begin


diadelasemana:=DayOfWeek(now);
numerodemes:=MonthOfTheYear(now);


if ((diadelasemana=1)) then
begin

ShowMessage('domingo: ' + inttostr(numerodemes));

end;


end;




.

maximo valor de int maximo entero

var
  min, max : integer;
begin
  // Set the minimum and maximum values of this data type
  min := Low(integer);
  max := High(integer);
  ShowMessage('Min integer value = '+IntToStr(min));
  ShowMessage('Max integer value = '+IntToStr(max));
end;

delphi tamaño de un fichero tamaño de un archivo

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    function tamanioA(nom:String):integer;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//********************************************
function TForm1.tamanioA(nom:String):integer;
var
FHandle: integer;
begin
FHandle := FileOpen(nom, 0);
try
Result := (getfilesize(FHandle,nil));
finally
FileClose(FHandle);
end;
end;

//***********************************************
procedure TForm1.Button1Click(Sender: TObject);
var
aux: string;
i: integer;
begin

aux:='c:\sella5.pdf';

i:=((tamanioA(aux) div 1024) div 1024);


ShowMessage(aux + ' --> ' +inttostr(i) + ' Mb');


end;

end.





.

showmessage salto de linea intros

ShowMessage('TU VIDA'+ #13#10 + 'SERA' + #13#10 +
'UNA CANCION');










.

adoquery saber si es null

//************************************************************************
procedure TForm1.Button1Click(Sender: TObject);
var
SQLQuery, aux: string;
begin

  ADOQuery1.Active := false;
  ADOQuery1.SQL.Clear;

  SQLQuery:='select * from borrar limit 1';
  ADOQuery1.SQL.Add(SQLQuery);

  ADOQuery1.Active := true;

  if  ADOQuery1.RecordCount > 0 then
  begin

    if ADOQuery1.FieldByName('nombre').IsNull then
    begin
      ShowMessage('nombre es null');
    end
    else
    begin
      aux:=ADOQuery1.FieldByName('nombre').AsString;
      ShowMessage(aux);
    end;

  end;

  ADOQuery1.Active := false;

end;



.

Crear un informe con RAVE v2

Tienes que añadir un control de la clase RvSystem y enlazar la propiedad engine del RvProject con el.

La Clase RVSystem tiene una propiedad SystemSetups donde puedes configurar las opciones de destinos (Impresora, preview, file..) si solo dejas opciones de impresión y ssAllowsetup a false, la impresión sale directa.

Si solo dejas opciones de Preview te saldra directamente la pantalla de previsualización y podras imprimir desde ella.

Saludos.

 

 

 

 

delphi copia portapapeles

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    Memo1: TMemo;
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  anterior: string;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
memo1.Clear;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
fic: textfile;
nuevo: boolean;
begin

timer1.Enabled:=false;

nuevo:=false;


if memo1.Text='' then
begin
  memo1.Clear;
  memo1.PasteFromClipboard;
 anterior:=memo1.Text;
 nuevo:=true;
end
else
begin

  memo1.Clear;
  memo1.PasteFromClipboard;

  if anterior<>memo1.Text then
  begin
    anterior:=memo1.Text;
    nuevo:=true;
  end;
end;

if nuevo=true then
begin

AssignFile (fic,'fondo.txt');
  if FileExists('fondo.txt')=false then
  begin
    ReWrite(fic);
  end
  else
  begin
    Append(fic);
  end;

Append(fic);
writeln(fic,memo1.Text);
CloseFile (fic);

end;


timer1.Enabled:=true;

end;

end.





.

fechas delphi dia mes año

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DateUtils;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
diadelasemana: integer;
wAnyo, wMes, wDia: Word;
begin

  DecodeDate( now(), wAnyo, wMes, wDia );

  diadelasemana:=DayOfWeek(now);

 // if ((diadelasemana=7) or (diadelasemana=1)) then



 ShowMessage(datetostr(EndOfTheMonth(now())));


  if (wMes=10) then
  begin

    if (wDia>=25) then
    begin
      ShowMessage(inttostr(wDia));
      ShowMessage(inttostr(wMes));
      ShowMessage(inttostr(wAnyo));
    end;

  end;


end;

end.



//*********
procedure TForm1.Button1Click(Sender: TObject);
var
wHor, wMin, wSeg, wMSeg, wAnyo, wMes, wDia: Word;
begin

DecodeDate( now(), wAnyo, wMes, wDia );
DecodeTime( now(), wHor, wMin, wSeg, wMSeg);

ShowMessage(inttostr(wHor)+inttostr(wMin)+inttostr(wSeg)+inttostr(wMSeg));

end;
 


.
 

saber si esta dentro de una zona GPS

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, strutils;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

  rectas: array[1..4] of string;

  puntosX: array[1..4] of integer;
  puntosY: array[1..4] of integer;

implementation

{$R *.dfm}


//********************************************************
procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
pX, pY: real;

desde, hasta: integer;

puntoOrdenado1, puntoOrdenado2: real;
denominador1, denominador2: real;
numerador, total: real;

corta: integer;

begin

  pX:=4;
  pY:=38.5596881;

  corta:=0;    // las veces que corta por arriba un punto dado
  desde:=1;    // los segmentos de la zona el primero
  hasta:=4;    // los segmentos de la zona el ultimo (en este ej.)
  //***
  for i := desde to hasta do
  begin

    if i<>4 then
    begin

        puntoOrdenado1:=puntosX[i];
        puntoOrdenado2:=puntosX[i+1];
       
        if (puntoOrdenado1>puntosX[i+1]) then
        begin
          puntoOrdenado1:=puntosX[i+1];
          puntoOrdenado2:=puntosX[i];
        end;

        if ((puntoOrdenado1<=pX) and (puntoOrdenado2>=pX)) then
        begin
          



    // ecuaciones de la recta  ((X - Xa) / (Xb - Xa)) = ((Y - Ya) / (Yb - Ya))


          numerador:=pX - puntosX[i+1];

          denominador1:= puntosX[i+1] - puntosX[i];
          denominador2:= puntosY[i+1] - puntosY[i];

          total:= (numerador * denominador2 / denominador1) +  puntosY[i+1];

          if total >= pY then
          begin
            corta:=corta+1;
          end;

          //showmessage(floattostr(total));

        end;

    end
    else
    begin

        puntoOrdenado1:=puntosX[desde];
        puntoOrdenado2:=puntosX[hasta];

        if (puntoOrdenado1>puntosX[hasta]) then
        begin
          puntoOrdenado1:=puntosX[hasta];
          puntoOrdenado2:=puntosX[desde];
        end;

        if ((puntoOrdenado1<=pX) and (puntoOrdenado2>=pX)) then
        begin

          numerador:=pX - puntosX[hasta];

          denominador1:= puntosX[hasta] - puntosX[desde];
          denominador2:= puntosY[hasta] - puntosY[desde];

          total:= (numerador * denominador2 / denominador1) +  puntosY[hasta];

          if total >= pY then
          begin
            corta:=corta+1;
          end;

          //showmessage(floattostr(total));

        end;

    end;

  end;


//  ShowMessage(inttostr(corta));

  if (corta mod 2 <> 0)  then
  begin
    ShowMessage('Dentro');
  end
  else
  begin
    ShowMessage('Fuera');
  end;


//  ShowMessage(floattostr(corta mod 2));


end;





//********************************************************
procedure TForm1.FormCreate(Sender: TObject);
begin

// vertices de la zona  (-5,3)   (6,9)   (3,5)   (9,-3)


puntosX[1]:=-5;
puntosX[2]:=6;
puntosX[3]:=3;
puntosX[4]:=9;


puntosY[1]:=3;
puntosY[2]:=9;
puntosY[3]:=5;
puntosY[4]:=-3;

end;




end.









http://es.onlinemschool.com/math/assistance/cartesian_coordinate/p_to_line/
http://fooplot.com



.

unir variable concatenar variable

cont:=listagrupos.Items.Count; // lineas de un lisbox


for i:=0 to listbox1.Items.Count-1 do
begin

if(listbox1.Selected[i]) then
begin
showmessage(inttostr(i));
end;
end;






sincronizar 4 listbox
/******************

procedure TForm1.ListBox1Click(Sender: TObject);
var
n:byte;
begin
for n:=2 to 4 do
begin
(FindComponent('ListBox'+IntToStr(n))as TListBox).ItemIndex:=
(Sender as TListBox).ItemIndex;
end;
end;


/****************



sincronizar 2 listbox
/******************

procedure TForm1.ListBox1Click(Sender: TObject);
var
n:byte;
begin
for n:=1 to 2 do
begin
(FindComponent('ListBox'+IntToStr(n))as TListBox).ItemIndex:=
(Sender as TListBox).ItemIndex;
end;
end;


/****************

base de datos select adoquery dinamico

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Data.DB, Data.Win.ADODB;

type
  TForm1 = class(TForm)
    ADOQuery1: TADOQuery;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//*************************************************
// aqui usa un componente ADOQUERY arrastrandolo
procedure TForm1.Button1Click(Sender: TObject);
var
SQLQuery: string;
begin


  ADOQuery1.Active := false;
  ADOQuery1.SQL.Clear;

  SQLQuery:='select id from localizadores limit 10';
  ADOQuery1.SQL.Add(SQLQuery);

  ADOQuery1.Active := true;

  if  ADOQuery1.RecordCount > 0 then
  begin
    showmessage('ok');
  end;

   ADOQuery1.Active := false;

end;

//*************************************************
// aqui crea un componente ADOQUERY dinamicamente
procedure TForm1.Button2Click(Sender: TObject);
var
ADOQuery2: TADOQuery;
SQLQuery: string;
i: integer;
begin

  ADOQuery2:= TADOQuery.Create(Self);
  ADOQuery2.ConnectionString:='Provider=MSDASQL.1;Persist Security Info=False;Data Source=elpauGPS';

  ADOQuery2.Active := false;
  ADOQuery2.SQL.Clear;

  SQLQuery:='select id from localizadores limit 10';
  ADOQuery2.SQL.Add(SQLQuery);


  ADOQuery2.Active := true;

  ShowMessage(inttostr(ADOQuery2.RecordCount));

  ADOQuery2.Active := false;

  ADOQuery2.Destroy;


end;

end.










// fin

coger la hora de internet

IdSNTP1.Host := 'time.windows.com';
label1.Caption := 'Fecha y hora: '+Datetimetostr(IdSNTP1.DateTime);

fecha a MySql formatear fecha

uses DateUtils

var
  myDate : TDateTime;

begin
  // Set up our TDateTime variable with a full date and time :
  // 5th of June 2000 at 01:02:03.004  (.004 milli-seconds)
  myDate := EncodeDateTime(2000, 6, 5, 1, 2, 3, 4);

  // Date only - numeric values with no leading zeroes (except year)
  ShowMessage('              d/m/y = '+
              FormatDateTime('d/m/y', myDate));

  // Date only - numeric values with leading zeroes
  ShowMessage('           dd/mm/yy = '+
              FormatDateTime('dd/mm/yy', myDate));

  // Use short names for the day, month, and add freeform text ('of')
  ShowMessage('  ddd d of mmm yyyy = '+
              FormatDateTime('ddd d of mmm yyyy', myDate));

  // Use long names for the day and month
  ShowMessage('dddd d of mmmm yyyy = '+
              FormatDateTime('dddd d of mmmm yyyy', myDate));

  // Use the ShortDateFormat settings only
  ShowMessage('              ddddd = '+
              FormatDateTime('ddddd', myDate));

  // Use the LongDateFormat settings only
  ShowMessage('             dddddd = '+
              FormatDateTime('dddddd', myDate));

  // Use the ShortDateFormat + LongTimeFormat settings
  ShowMessage('                  c = '+
              FormatDateTime('c', myDate));
end;


o por ejemplo en una QUERY


  SQLQuery:='SELECT sum(CAST(metros AS UNSIGNED)) as metros FROM records ';
  SQLQuery:= SQLQuery +'where ';
  SQLQuery:= SQLQuery +'localizadorid="'+localizadores[i]+'" ';
  SQLQuery:= SQLQuery +'and contacto="1" ';
  SQLQuery:= SQLQuery +'and fecha="'+FormatDateTime('yyyy-mm-dd', now-1)+'" ';



// now-1   es el dia de ayer para anteayer seria now-2

.

delphi listar archivos y directorios

 function TForm1.ListaDirectorios(directorioPadre: string) : TStringList;
  var
    sr: TSearchRec;
  begin
    Result := TStringList.Create;
    if FindFirst(directorioPadre + '*', faDirectory, sr) = 0 then
    repeat
      if (sr.Attr = faDirectory) then
        Result.Add(directorioPadre + sr.Name);
    until FindNext(sr) <> 0;
    FindClose(sr);
  end;
 
  function TForm1.ListaArchivos(directorioPadre: string) : TStringList;
  var
    sr: TSearchRec;
  begin
    Result := TStringList.Create;
    if FindFirst(directorioPadre + '*', faAnyFile, sr) = 0 then
      repeat
        if (sr.Attr and faDirectory = 0) or (sr.Name <> '.')
          and (sr.Name <> '..') then
            Result.Add(directorioPadre + sr.Name);
      until FindNext(sr) <> 0;
    FindClose(sr);
  end;
 
    
     // Llamando a las funciones anteriores
 procedure TForm1.Button1Click(Sender: TObject);
  begin
    ListBox1.Items := ListaDirectorios('C:\');
    ListBox2.Items := ListaArchivos('C:\');
  end;

delphi borrar fichero

procedure TForm1.Button1Click(Sender: TObject);
begin

  if FileExists('c:\borrar.txt') then
    DeleteFile('c:\borrar.txt');

end;

delphi tamaño de un fichero

procedure TForm1.Button1Click(Sender: TObject);
var
  F: File of byte;
begin
  AssignFile( F, 'c:\ftp2.bat' );
  Reset( F );
  ShowMessage( IntToStr( FileSize( F ) ) + ' bytes' );
  CloseFile( F );

end;







.

delphi try catch global en el form

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure GlobalExceptionHandler(Sender: TObject; E: Exception);
    procedure Button1Click(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }


  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//***********************************************************************
procedure TForm1.Button1Click(Sender: TObject);
var
i,j: integer;
begin

  j:=0;
  i:=10 div j;

end;

//***********************************************************************
procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnException := GlobalExceptionHandler;
end;

//***********************************************************************
procedure TForm1.GlobalExceptionHandler(Sender: TObject; E: Exception);
var
fic: textfile;
begin

  AssignFile (fic,'logerrores.txt');
  if FileExists('logerrores.txt')=false then
  begin
    ReWrite(fic);
  end
  else
  begin
    Append(fic);
  end;

  writeln(fic,datetostr(now()) + ' ' + timetostr(now()));
  writeln(fic,'-------------------------------------------------------------------');
  writeln(fic,'Exception class name = '+E.ClassName);
  writeln(fic,'Exception message = '+E.Message);
  writeln(fic,'');  CloseFile (fic);

end;

end.

delphi try catch

var
fic: textfile;


(...)
 
try
  j:=0;
  i:=1 div j;

  except
  on E : Exception do
  begin

  AssignFile (fic,'logerrores.txt');

  if FileExists('logerrores.txt')=false then
  begin
    ReWrite(fic);
  end
  else
  begin
    Append(fic);
  end;

  writeln(fic,datetostr(now()) + ' ' + timetostr(now()));
  writeln(fic,'-------------------------------------------------------------------');
  writeln(fic,'Exception class name = '+E.ClassName);
  writeln(fic,'Exception message = '+E.Message);
  writeln(fic,'');
  CloseFile (fic);
  end;


.

espera a que termine shellexecute

procedure ExecuteAndWait(const aCommando: string);


 (...)


//*****************
procedure TForm1.ExecuteAndWait(const aCommando: string);
var
  tmpStartupInfo: TStartupInfo;
  tmpProcessInformation: TProcessInformation;
  tmpProgram: String;
begin
  tmpProgram := trim(aCommando);
  FillChar(tmpStartupInfo, SizeOf(tmpStartupInfo), 0);
  with tmpStartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    wShowWindow := SW_HIDE;
  end;

  if CreateProcess(nil, pchar(tmpProgram), nil, nil, true, CREATE_NO_WINDOW,
    nil, nil, tmpStartupInfo, tmpProcessInformation) then
  begin
    // loop every 10 ms
    while WaitForSingleObject(tmpProcessInformation.hProcess, 10) > 0 do
    begin
      Application.ProcessMessages;
    end;
    CloseHandle(tmpProcessInformation.hProcess);
    CloseHandle(tmpProcessInformation.hThread);
  end
  else
  begin
    RaiseLastOSError;
  end;
end;

(...)

//**********************************************
procedure TForm1.Button1Click(Sender: TObject);
var
aux: string;
begin

aux:='C:\Users\Pau\Desktop\blat.exe -server smtp.1und1.de -port 587 -f "root@mgflotas.com" -to "informaticoalicante@gmail.com" -subject "AVISO MGFLOTAS " -body "PAU" -u root@mgflotas.com -pw 91919191aA -html';
ExecuteAndWait(aux);

end;

tamaño de una carpeta de windows

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);



  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


//**********************************************************************
procedure BuscarArchivos(const directorio, mascara: string;
  atributos: Integer; var listado: TStrings);

  // Procedimiento anidado
  //
  procedure Buscar(const subdirectorio: string);
  var
    regBusqueda: TSearchRec;
  begin
    // Buscar en el directorio
    if FindFirst(subdirectorio + mascara,atributos,regBusqueda) = 0 then
    begin
      try
        repeat
          Application.ProcessMessages;
          if (regBusqueda.Attr and faDirectory = 0)
            or (regBusqueda.Name <> '.')
              and (regBusqueda.Name <> '..') then
              begin
                //listado.Add(subdirectorio + (regBusqueda.Name)+ ' --> '+ inttostr(regBusqueda.Size));
                listado.Add(inttostr(regBusqueda.Size));
              end;
        until FindNext(regBusqueda) <> 0;
      except
        FindClose(regBusqueda);
      end;
      FindClose(regBusqueda);
    end;

    // Buscar en los subdirectorios
    if FindFirst(subdirectorio + '*', atributos
      or faDirectory, regBusqueda) = 0 then
    begin
      try
        repeat
          Application.ProcessMessages;
          if ((regBusqueda.Attr and faDirectory) <> 0)
            and (regBusqueda.Name <> '.')
              and (regBusqueda.Name <> '..') then
                Buscar(subdirectorio + regBusqueda.Name + '\');
        until FindNext(regBusqueda) <> 0;
      except
        FindClose(regBusqueda);
      end;
      FindClose(regBusqueda);
    end;
  end;
   //
  // Fin del procedimiento anidado:
 // Comienza "BuscarArchivos(...)"
//
begin
  Buscar(IncludeTrailingPathDelimiter(directorio));
end;



procedure TForm1.Button1Click(Sender: TObject);
var
  lista: TStrings;
  total,  aux: real;
  i: integer;
  nombre: string;

begin
  lista := TStringList.Create;
  BuscarArchivos('C:\mgflo\video\', '*.*', faAnyFile, lista);

  memo1.clear;

  total:=0;

 for i := 0 to lista.Count-1 do
 begin

    nombre:=  lista[i];
    aux:=(strtofloat(nombre) / 1024 / 1024);
    total:=total+aux;

    memo1.Lines.Add(floattostr(aux));
 end;

     memo1.Lines.Add('---------------------------');
     memo1.Lines.Add(floattostr(total / 1024));

//  FormatFloat ('0.00', total).


  lista.Free;
end;

end.






.

delphi funcion pasar por valor

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
function porvalor(var dato: string):bool;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//************************************
procedure TForm1.Button1Click(Sender: TObject);
var
a: string;
begin

porvalor(a);
ShowMessage(a);

end;

//************************************
function TForm1.porvalor(var dato: string):bool;
begin

dato:='hola';

end;


end.

sumar o restar horas

hora1:= now();

// resta una hora
ShowMessage(timetostr(hora1 - 60 / 1440));


// suma 40 minutos
ShowMessage(timetostr(hora1 + 40 / 1440));







.

Cerrar una ventana por su titulo con Delphi (cerrar un programa)

procedure TForm1.Button2Click(Sender: TObject);
var
  aHWnd : HWND;
begin
  aHWnd := FindWindow(nil, 'Google - Mozilla Firefox');

  if (aHWnd <> 0) then
    PostMessage(aHWnd, WM_QUIT, 0, 0);
    // or ...
    //PostMessage(aHWnd, WM_CLOSE, 0, 0);
end;

Abrir un programa desde Delphi

 uses ShellApi;

 ...

 ShellExecute(Handle, 'open', 'c:\Windows\notepad.exe', nil, nil, SW_SHOWNORMAL) ; 

delphi como funciona un dblookupcombobox combobox con dos tablas

necesitamos rellenar los siguientes campos:


ListField // lo que muestra en el combo
KeyField // el valor que coge el combo
ListSource // de donde maman estos dos campos de arriba


DataField // lo que modifica el combo (esta relacionado con el KeyField)
DataSource // donde mama el campo DataField


.

delphi dia de la semana

procedure TForm1.Button1Click(Sender: TObject);
var
diaSemana: string;
begin
diaSemana := FormatDateTime('dddd', Date);

showmessage(diaSemana);
end;

operaciones con string en delphi

Concat function
Concatenates two or more strings into a single string.
CompareStr function
Compares two strings.
CompareText function
Compares two strings without case sensitivity.
Copy function
Returns a substring of a string or a segment of a dynamic array.
Delete procedure
Removes a substring from a string.
DupeString function
Returns a string repeated a specified number of times.
ExtractStrings function
Fills a string list with substrings parsed from a delimited list.
Insert procedure
Inserts a substring into a string at a given position.
IsDelimiter function
Returns True if a specified character in a string matches one of a set of delimiters starting from some position.
LastDelimiter function
Returns the index of the last occurence in a string of the characters cpecified.
LeftStr function
Returns a string containing a specified number of characters from the left side of a string.
Length function
Returns an integer containing the number of characters in a string or the number of elements in an array.
LowerCase function
Returns a string that has been converted to lowercase.
Pos function
Returns an integer specifying the position of the first occurrence of one string within another.
PosEx function
Returns an integer specifying the position of the first occurrence of one string within another, where the search starts at a specified position.
QuotedStr function
Returns the quoted version of a string.
ReverseString function
Returns a string in which the character order of a specified string is reversed.
RightStr function
Returns a string containing a specified number of characters from the right side of a string.
SetLenght procedure
Changes the size of a dynamic array or a string.
SetString procedure
Sets the lenght and contents of a given string.
Str procedure
Formats a string from an integer or floating point variable.
StringOfChar function
Returns a string containing a repeating character string of the length specified.
StringReplace function
Returns a string in which a specified substring has been replaced with another substring.
Trim function
Returns a string containing a copy of a specified string without both leading and trailing spaces and control characters.
TrimLeft function
Returns a string containing a copy of a specified string without leading spaces and control characters.
TrimRight function
Returns a string containing a copy of a specified string without trailing spaces and control characters.
UpperCase function
Returns a string that has been converted to uppercase.
Val procedure
Converts a string to a numeric value.
WrapText function
Returns a string broken into multiple lines.

Borrar ficheros del disco con dephi

procedure Tfrm.BorrarFichero(fichero: String);

begin
if FileExists(fichero) then
 DeleteFile(fichero);
end;

arreglar Key Violation en clave primaria tabla Paradox

Si al insertar un nuevo regristro en una tabla Paradox que tiene un campo autonumérico te da error haz lo siguiente:

1) abrir DataBase Desktop





2) Abrir la tabla en cuestion




3) Pincha en el boton RESTRUCTURE y dentro ve a la columna TYPE del campo que falla (el autoincrement) y cambia el + por I guarda la tabla, cambialo como estaba (el I por el +) y guarda la tabla de nuevo.

Filtrar una tabla sin una query

procedure TForm1.Button1Click(Sender: TObject);
begin

table1.Filter:='cocheid >= 15 and cocheid <=20 or cochematricula = ' + QuotedStr('0755-DXR');
table1.Filtered:=true;

end;

ojo !! si se quiere filtrar con un LIKE sería así:

//*** asi no va
clientes.Filter:='ClientesNomApellidos like ' + QuotedStr('%'+edit1.text+'%');

//*** asi SI (ojo en Paradox solo funciona para los campos en que les pasemos como comienzan, no va ni con terminan, ni contienen)
clientes.Filter:='ClientesNomApellidos= '+QuotedStr(Edit1.text+'*');
clientes.Filtered:=true;

poner entre comillas un string

procedure TForm1.Button1Click(Sender: TObject);
var
dato: string;
begin

dato:='hola';

// sin comillas
showmessage(dato);

// con comillas
showmessage(QuotedStr(dato));


end;

Word to char

//*** Key es de tipo CHAR
//*** VK_MENUes de tipo WORD


if Key=Chr(VK_MENU) then
begin
// lo q sea
end;


.

tecla ALT tecla ENTER y mas teclas

//***********************
if Key=Chr(VK_MENU) then
begin
showmessage('tecla ALT pulsada');
end;


//***********************
if Key=#13 then
begin
showmessage('tecla ENTER pulsada');
end;


//******************************************************************
VK_LBUTTON 01 Left mouse button
VK_RBUTTON 02 Right mouse button
VK_CANCEL 03 Control-break processing
VK_MBUTTON 04 Middle mouse button (three-button mouse)
VK_BACK 08 BACKSPACE key
VK_TAB 09 TAB key
VK_CLEAR 0C CLEAR key
VK_RETURN 0D ENTER key
VK_SHIFT 10 SHIFT key
VK_CONTROL 11 CTRL key
VK_MENU 12 ALT key
VK_PAUSE 13 PAUSE key
VK_CAPITAL 14 CAPS LOCK key
VK_ESCAPE 1B ESC key
VK_SPACE 20 SPACEBAR
VK_PRIOR 21 PAGE UP key
VK_NEXT 22 PAGE DOWN key
VK_END 23 END key
VK_HOME 24 HOME key
VK_LEFT 25 LEFT ARROW key
VK_UP 26 UP ARROW key
VK_RIGHT 27 RIGHT ARROW key
VK_DOWN 28 DOWN ARROW key
VK_SELECT 29 SELECT key
VK_PRINT 2A PRINT key
VK_EXECUTE 2B EXECUTE key
VK_SNAPSHOT 2C PRINT SCREEN key
VK_INSERT 2D INS key
VK_DELETE 2E DEL key
VK_HELP 2F HELP key
30 0 key
31 1 key
32 2 key
33 3 key
34 4 key
35 5 key
36 6 key
37 7 key
38 8 key
39 9 key
41 A key
42 B key
43 C key
44 D key
45 E key
46 F key
47 G key
48 H key
49 I key
4A J key
4B K key
4C L key
4D M key
4E N key
4F O key
50 P key
51 Q key
52 R key
53 S key
54 T key
55 U key
56 V key
57 W key
58 X key
59 Y key
5A Z key
VK_NUMPAD0 60 Numeric keypad 0 key
VK_NUMPAD1 61 Numeric keypad 1 key
VK_NUMPAD2 62 Numeric keypad 2 key
VK_NUMPAD3 63 Numeric keypad 3 key
VK_NUMPAD4 64 Numeric keypad 4 key
VK_NUMPAD5 65 Numeric keypad 5 key
VK_NUMPAD6 66 Numeric keypad 6 key
VK_NUMPAD7 67 Numeric keypad 7 key
VK_NUMPAD8 68 Numeric keypad 8 key
VK_NUMPAD9 69 Numeric keypad 9 key
VK_SEPARATOR 6C Separator key
VK_SUBTRACT 6D Subtract key
VK_DECIMAL 6E Decimal key
VK_DIVIDE 6F Divide key
VK_F1 70 F1 key
VK_F2 71 F2 key
VK_F3 72 F3 key
VK_F4 73 F4 key
VK_F5 74 F5 key
VK_F6 75 F6 key
VK_F7 76 F7 key
VK_F8 77 F8 key
VK_F9 78 F9 key
VK_F10 79 F10 key
VK_F11 7A F11 key
VK_F12 7B F12 key
VK_F13 7C F13 key
VK_F14 7D F14 key
VK_F15 7E F15 key
VK_F16 7F F16 key
VK_F17 80H F17 key
VK_F18 81H F18 key
VK_F19 82H F19 key
VK_F20 83H F20 key
VK_F21 84H F21 key
VK_F22 85H F22 key
VK_F23 86H F23 key
VK_F24 87H F24 key
VK_NUMLOCK 90 NUM LOCK key
VK_SCROLL 91 SCROLL LOCK key
VK_LSHIFT A0 Left SHIFT key
VK_RSHIFT A1 Right SHIFT key
VK_LCONTROL A2 Left CONTROL key
VK_RCONTROL A3 Right CONTROL key
VK_LMENU A4 Left MENU key
VK_RMENU A5 Right MENU key
VK_PLAY FA Play key
VK_ZOOM FB Zoom key


.

comprobar que un textbox sea numero isnum

function IsStrANumber(NumStr : string) : bool;


//***********************
function IsStrANumber(NumStr : string) : bool;
begin
result := true;

try
StrToInt(NumStr);
except
result := false;
end;

end;
//****



if IsStrANumber(edit2.Text)=false then
begin
showmessage('El campo UNIDADES debe de ser un número.');
exit;
end;

.

crear un TDBText dinamico dinamicamente

var
fechaSalida: TDBText;

(...)

fechaSalida:= TDBText.Create(Self);
fechaSalida.DataField:='fechaSalida';
fechaSalida.DataSource:=DataSource3;

sumar tiempo sumar horas en SQL Paradox 7

(...)

var
resumen: Tform1;
function sumahoras(hora1: ttime; hora2: ttime): string;

implementation

{$R *.dfm}

(...)


//

---

function sumahoras(hora1: ttime; hora2: ttime): string;
var
h1,h2,m1,m2,s1,s2: integer;
h,m,s: integer;
aux, horaFinal: string;
begin


//**** hora 1
aux:= timetostr(hora1);

if (length(timetostr(hora1))=7) then
begin
aux:='0';
aux:=aux + timetostr(hora1);
end;

h1:= strtoint(aux[1]+aux[2]);
m1:= strtoint(aux[4]+aux[5]);
s1:= strtoint(aux[7]+aux[8]);

//**** hora 2
aux:= timetostr(hora2);

if (length(timetostr(hora2))=7) then
begin
aux:='0';
aux:=aux + timetostr(hora2);
end;


h2:= strtoint(aux[1]+aux[2]);
m2:= strtoint(aux[4]+aux[5]);
s2:= strtoint(aux[7]+aux[8]);

//

---

if ((s1+s2) > 59) then
begin
m1:=m1+1;
s:= (s1+s2) - 60;
end
else
begin
s:= (s1+s2);
end;


//

---

if ((m1+m2) > 59) then
begin
h1:=h1+1;
m:= (m1+m2) - 60;
end
else
begin
m:= (m1+m2);
end;

//

---

h:=h1+h2;


horaFinal:='00:00:00';
aux:=inttostr(s);

if (length(aux)<2) then
begin
horaFinal[7]:='0';
horaFinal[8]:=aux[1];
end
else
begin
horaFinal[7]:=aux[1];
horaFinal[8]:=aux[2];
end;

aux:=inttostr(m);

if (length(aux)<2) then
begin
horaFinal[4]:='0';
horaFinal[5]:=aux[1];
end
else
begin
horaFinal[4]:=aux[1];
horaFinal[5]:=aux[2];
end;


aux:=inttostr(h);

if (length(aux)<2) then
begin
horaFinal[1]:='0';
horaFinal[2]:=aux[1];
end
else
begin
horaFinal[1]:=aux[1];
horaFinal[2]:=aux[2];
end;

sumahoras:= horaFinal;

end;


//

---

//** ejemplo de llamada en una QUERY
//

---

(...)

aux:='select * from almuerzos where almuerzoFechaEntrada is not null and almuerzoFechaSalida >= :fechaD and almuerzoFechaSalida<= :fechaH and almuerzoEmpleado = ' + empleadoID ;

qAlmuerzos.close;
qAlmuerzos.SQL.Clear;
qAlmuerzos.SQL.add(aux);

qAlmuerzos.ParamByName('fechaD').DataType:= ftDate;
qAlmuerzos.ParamByName('fechaD').Value:= DateTimePicker1.Date;

qAlmuerzos.ParamByName('fechaH').DataType:= ftDate;
qAlmuerzos.ParamByName('fechaH').Value:= DateTimePicker2.Date;

qAlmuerzos.Active:=true;

qAlmuerzos.First;
totalTiempoAlmuerzo:= '00:00:00';
for i:=0 to qAlmuerzos.RecordCount-1 do
begin
totalTiempoAlmuerzo:= (sumahoras(strtotime(totalTiempoAlmuerzo), qAlmuerzos.Fieldvalues['almuerzoTotalTiempo']));
qAlmuerzos.next;
end;

(...)

Mensaje YES NO por defecto el NO

if Application.MessageBox(PChar(‘¿Te vas a casa?’), PChar(‘Confirmar’), MB_YESNO or MB_DEFBUTTON2 or MB_ICONQUESTION) = IDNO then
begin
// lo que sea
end;

SQL con parametros

query1.close;
query1.SQL.Clear;
query1.SQL.add('insert into query1 (fecha, importeT, importeE, concepto, empleado, total) values (:fecha, :importeT, :importeE, :concepto, :empleado, :total)');
query1.ParamByName('fecha').Value:=Date;
query1.ParamByName('importeE').Value:=strtofloat(StringGrid1.Cells[2,i]);
query1.ParamByName('importeT').Value:=strtofloat('0');
query1.ParamByName('concepto').Value:=StringGrid1.Cells[0,i];
query1.ParamByName('empleado').Value:=StringGrid1.Cells[1,i];
query1.ParamByName('total').Value:=strtofloat(StringGrid1.Cells[2,i]);
query1.ExecSQL;

Crear un informe con RAVE

Primero colocamos los siguientes componentes en el Formulario



Modificamos las propiedades del componente Query1
(poniendo en la propiedad SQL la sql p.e. select * from cobros)










y dentro del boton que llama al iforme




pinchamos dos veces en el componente RV Rave y se abre el rave
una vez dentro para modificar las propiedades de la hoja vamos aqui



Añadimos una region




depues añadimos una banda estatica (para datos que siempre son iguales)
o una banda dinamica (donde pinta las filas del QUERY1)





Hacemos que traiga los campos de la query1 al report












aqui se muestran los campos que hay (ojo no los podemos arrastras al report)
OJO: si se usa la banda dinamica hay que ponerle la propiedad DATAVIEW el que corresponda de la QUERY




Para ponerlo en el reporte ponemos un componente de datos tipo texto




y en las propiedades lo asociamos




//**************************

si queremos pasarle parámetros desde la aplicacion de un textbox por ejemplo al informe entonces haremos: (EN EL CODIGO DEL PROGRAMA)


RvProject1.SetParam(‘fechaD’, datetostr(DateTimePicker1.Date));

y en el informe haremos:

- poner un datatext
- pulsar los puntos suspensivos de su datafield
- en el campo de abajo (data text) pondremos p.e.
'Desde ' & Param.fechaD







FIN :D





.

Mesanej personalizado con YES o NO

if MessageDlg('¿Desea borrar la fila?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then
begin
// lo que sea
end;

borrar una fila de un stringgrid

//*****
ponemos un stringgrid y un boton en el formulario

y usaremos una variable global que se llama FILA para saber que fila se tiene que borrar cuando pulse el boton



//***********************************************


unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids;

type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
Button1: TButton;
procedure FormActivate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

//****** variable global
fila: integer;

implementation

{$R *.dfm}

procedure TForm1.FormActivate(Sender: TObject);
begin

fila:=-1;

with StringGrid1 do
begin
// Título de las columnas
Cells[1, 0] := 'NOMBRE';
Cells[2, 0] := 'APELLIDO1';
Cells[3, 0] := 'APELLIDO2';
Cells[4, 0] := 'NIF';
Cells[5, 0] := 'IMPORTE PTE.';

// Datos
Cells[1, 1] := 'PABLO';
Cells[2, 1] := 'GARCIA';
Cells[3, 1] := 'MARTINEZ';
Cells[4,1] := '67348321D';
Cells[5,1] := '1500,36';

// Datos
Cells[1, 2] := 'MARIA';
Cells[2, 2] := 'SANCHEZ';
Cells[3, 2] := 'PALAZON';
Cells[4, 2] := '44878234A';
Cells[5, 2] := '635,21';

// Datos
Cells[1, 3] := 'CARMEN';
Cells[2, 3] := 'PEREZ';
Cells[3, 3] := 'GUILLEN';
Cells[4, 3] := '76892693L';
Cells[5, 3] := '211,66';
end;


end;

procedure GridDeleteRow(RowNumber: Integer; Grid: TstringGrid);
var
i: Integer;
begin



Grid.Row := RowNumber;

for i := RowNumber to Grid.RowCount - 1 do
Grid.Rows[i] := Grid.Rows[i + 1];

Grid.RowCount := Grid.RowCount - 1;


end;

procedure TForm1.Button1Click(Sender: TObject);
begin

if (fila<>-1) then
begin

GridDeleteRow(fila, stringGrid1);
fila:=-1;
end;

end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
ARow: Integer; var CanSelect: Boolean);
begin

fila:= ARow;

end;

end.







.

SQL delete

query1.Close;
query1.SQL.Clear;
query1.SQL.Add('delete from historico where id='+inttostr(id)+' and fecha='+#39+Getfecha+#39);
query1.ExecSQL;

SQL insert

query1.Close;
query1.SQL.Clear;
query1.SQL.Add('insert into historico (proveedor,fecha,articulo,talla,pcoste,pvp) values ('+#39+proveedor+#39+','+#39+Getfecha+#39+','+#39+edit1.text+#39+','+#39+edit2.text+#39+','+#39+floattostr(pcoste)+#39+','+#39+floattostr(pvp)+#39+')');
query1.ExecSQL;

DATETIMEPICKER otras funciones posiblemente interesantes

uses
ComCtrls;

const
DTM_SETFORMAT = $1005;

procedure TForm1.Button1Click(Sender: TObject);
var
sFormat: string;
begin
DateTimePicker1.kind := dtkTime;

// Don't show the seconds, Sekunden nicht anzeigen
SendMessage(DateTimePicker1.Handle, DTM_SETFORMAT, 0, Longint(PChar('hh:mm')));

// To show AM/PM
SendMessage(DateTimePicker1.Handle, DTM_SETFORMAT, 0, Longint(PChar('hh:mm tt')));

// 24-hour clock: Be sure to set Kind to dtkTime
DateTime_SetFormat(DateTimePickerTest.Handle, pChar('H:mm:ss'));

// To show Date and Time, Datum und Zeit anzeigen
// Note that you can only edit the date or the time depending
// on the Kind (dtkTime or dtkDate).
SendMessage(DateTimePicker1.Handle, DTM_SETFORMAT, 0, Longint(PChar('dd/MM/yyyy hh:ss')));

// You could also use the DateTime_SetFormat macro:
DateTime_SetFormat(DateTimePicker1.Handle, PChar('M/d/yyy'));

// Instead of using the DateTime_SetFormat function, you can
// send a message to the control directly:
sFormat := 'dd-MMMM-yyyy';
DateTimePicker1.Perform(DTM_SETFORMAT, 0, DWORD(sFormat));
end;

// Show the Week Number in a TDateTimePicker

procedure DateToWeek(dtDate: TDateTime; var AWeek, AYear: Word);
const
FIRST_WEEKDAY: Integer = 2;
FIRST_WEEKDATE: Integer = 4;
var
wMonth, wDay: Word;
begin
dtDate := dtDate - ((DayOfWeek(dtDate) - FIRST_WEEKDAY + 7) mod 7) + 7 - FIRST_WEEKDATE;
DecodeDate(dtDate, AYear, wMonth, wDay);
AWeek := (Trunc(dtDate - EncodeDate(AYear, 1, 1)) div 7) + 1;
end;

procedure TForm1.DateTimePicker1Change(Sender: TObject);
var
sFormat: string;
wWeek, wYear: Word;
begin
DateToWeek(DateTimePicker1.date, wWeek, wYear);
sFormat := 'dd/MM/yy Week:' + IntToStr(wWeek) + '';
DateTimePicker1.Perform(DTM_SETFORMAT, 0, DWORD(sFormat));
end;

procedure TForm1.FormShow(Sender: TObject);
begin
DateTimePicker1Change(Self);
end;