Archivo

Entradas Etiquetadas ‘Programación’

Buscar ficheros en un directorio y guardarlos en un TStringList (recursico)

jueves, 24 de julio de 2008 4 comentarios
Share Button

Función para buscar ficheros en un directorio de forma recursiva.
Devuelve una lista de nombres de fichero encontrados a partir de la carpeta inicial StartDir, que cumplen el patrón especificado por FileMask.

Mediante recursively se indica si se desea
hacer la busqueda en los subdirectorios.

El resultado se devuelve en FilesList (TStringList), que es la lista que se rellena con los nombres de fichero encontrados.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
{: Devuelve una lista de nombres de fichero encontrados a partir 
de la carpeta inicial StartDir, que cumplen el patrón especificado 
por FileMask.Mediante recursively se indica si se desea hacer la
 busqueda en los subdirectorios.
StartDir Carpeta desde la que empezar a buscar.
FileMask Patrón que han de cumplir los ficheros.
Recursively Si hay que continuar la búsqueda en los subdirectorios.
FilesList Lista con los nombres de fichero encontrados.
}
procedure FindFiles(StartDir, FileMask: string; 
                 recursively: boolean; var FilesList: TStringList);
const
  MASK_ALL_FILES = '*.*';
  CHAR_POINT = '.';
var
  SR: TSearchRec;
  DirList: TStringList;
  IsFound: Boolean;
  i: integer;
begin
 
  if (StartDir[length(StartDir)] <> '\') then begin
    StartDir := StartDir + '\';
  end;
 
  // Crear la lista de ficheos en el dir. StartDir (no directorios!)
  IsFound := FindFirst(StartDir + FileMask, 
                  faAnyFile - faDirectory, SR) = 0;
 
  // MIentras encuentre
  while IsFound do begin
    FilesList.Add(StartDir + SR.Name);
    IsFound := FindNext(SR) = 0;
  end;
 
  FindClose(SR);
 
  // Recursivo?
  if (recursively) then begin
    // Build a list of subdirectories
    DirList := TStringList.Create;
    // proteccion
    try
    IsFound := FindFirst(StartDir + MASK_ALL_FILES, 
                   faAnyFile, SR) = 0;
    while IsFound do begin
      if ((SR.Attr and faDirectory) <> 0) and 
          (SR.Name[1] <>  CHAR_POINT) then begin
        DirList.Add(StartDir + SR.Name);
        IsFound := FindNext(SR) = 0;
      end; // if
    end; // while
    FindClose(SR);
    // Scan the list of subdirectories
    for i := 0 to DirList.Count - 1 do begin
      FindFiles(DirList[i], FileMask, recursively, FilesList);
    end;
 
    finally
      DirList.Free;
    end;
  end;
end;

Utilizar un BMP para cambiar el cursor

martes, 6 de mayo de 2008 1 comentario
Share Button

Muestra como utilizar un BITMAP (en este caso extraído de un TImage) para modificar el cursor activo. Modificando un poco el Tip/Truco es fácil obtener la imagen de disco o desde un recurso.

Se utiliza la API CreateIconIndirect para generar el cursor que posteriormente se activará.

Se puede usar un color de fondo como transparente para obtener un cursos «opaco» o un segundo BITMAP para combinarlo con el primero y así obtener también efectos de transparencia en el cursor generado.

Imagen del ejemplo

// Crear los bitmaps
BitmapMask := TBitmap.Create;
Bitmap := TBitmap.Create;
// proteccion
try
  // Cargar las imágenes
  BitmapMask.Assign(Image2.Picture.Bitmap);
  Bitmap.Assign(Image1.Picture.Bitmap);
  // Crear el icono del cursor
  with iconInfo do begin
    fIcon := false;
    xHotspot := (Bitmap.Width div 4);
    yHotspot := (Bitmap.Height div 3);
    hbmMask := BitmapMask.Handle;
    hbmColor := Bitmap.Handle;
  end;
 
  // Asignar el icono
  Screen.Cursors[1] := CreateIconIndirect(iconInfo);
  Self.Cursor := 1;
 
finally
  // Liberar
  BitmapMask.Free;
  Bitmap.Free;
end;

Es ejemplo completo se puede descargar <AQUÍ>.
Download Descargar.

Categories: Delphi, Trucos Tags: , , ,

Fechas de un fichero (creación, modificación y últ. acceso)

sábado, 29 de marzo de 2008 2 comentarios
Share Button

Para cualquier fichero que se encuentra en el sistema de archivos de Windows se almacenan varias fechas. Para acceder a todas ellas puede utilizar el siguiente truco:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
// ================================================================
// Return the three dates (Created,Modified,Accessed)
// of a given filename. Returns FALSE if file cannot
// be found or permissions denied. Results are returned
// in TdateTime VAR parameters
// ================================================================
// ================================================================
// Devuelve las tres fechas (Creación, modificación y último acceso)
// de un fichero que se pasa como parámetro.
// Devuelve FALSO si el fichero no se ha podido acceder, sea porque
// no existe o porque no se tienen permisos. Las fechas se devuelven
// en tres parámetros de ipo DateTime
// ================================================================
function GetFileTimes(FileName : string; var Created : TDateTime;
    var Modified : TDateTime; var Accessed : TDateTime) : boolean;
var
   FileHandle : integer;
   Retvar : boolean;
   FTimeC,FTimeA,FTimeM : TFileTime;
   LTime : TFileTime;
   STime : TSystemTime;
begin
  // Abrir el fichero
  FileHandle := FileOpen(FileName,fmShareDenyNone);
  // inicializar
  Created := 0.0;
  Modified := 0.0;
  Accessed := 0.0;
  // Ha tenido acceso al fichero?
  if FileHandle < 0 then
    RetVar := false
  else begin
 
    // Obtener las fechas
    RetVar := true;
    GetFileTime(FileHandle,@FTimeC,@FTimeA,@FTimeM);
    // Cerrar
    FileClose(FileHandle);
    // Creado
    FileTimeToLocalFileTime(FTimeC,LTime);
 
    if FileTimeToSystemTime(LTime,STime) then begin
      Created := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
      Created := Created + EncodeTime(STime.wHour,STime.wMinute,
              STime.wSecond, STime.wMilliSeconds);
    end;
 
    // Accedido
    FileTimeToLocalFileTime(FTimeA,LTime);
 
    if FileTimeToSystemTime(LTime,STime) then begin
      Accessed := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
      Accessed := Accessed + EncodeTime(STime.wHour,STime.wMinute,
              STime.wSecond, STime.wMilliSeconds);
    end;
 
    // Modificado
    FileTimeToLocalFileTime(FTimeM,LTime);
 
    if FileTimeToSystemTime(LTime,STime) then begin
      Modified := EncodeDate(STime.wYear,STime.wMonth,STime.wDay);
      Modified := Modified + EncodeTime(STime.wHour,STime.wMinute,
                     STime.wSecond, STime.wMilliSeconds);
    end;
  end;
  Result := RetVar;
end;

Para llamar a ésta función se puede utilizar un código como éste:

1
2
3
4
5
6
7
8
9
10
var
   CDate,MDate,ADate : TDateTime;
begin
  // Correcto?
  if GetFileTimes('c:\autoexec.bat', CDate, MDate, ADate) then begin
    Label1.Caption := FormatDateTime('dd/mm/yyyy hh:nn',CDate);
    Label2.Caption := FormatDateTime('dd/mm/yyyy hh:nn',MDate);
    Label3.Caption := FormatDateTime('dd/mm/yyyy hh:nn',ADate);
  end;
end;

Dibujar una flecha (ordenación) en el título de un DBGrid

sábado, 15 de marzo de 2008 9 comentarios
Share Button

A veces nos puede interesar dibujar en el título de un DBGrid una flecha para indicar la ordenación ASCENDENTE o DESCENDENTE sobre esa columna; De forma muy similar a como se muesta aquí, se pueden dibujar otros símbolos e incluso colocar imágenes.

Para conseguir ésto se debe derivar el componente de DBGrid estandard y añadir los dos métodos de dibujo a la parte privada:

{ Private declarations }
procedure __PaintArrowUp(Canvas: TCanvas; var Rect: TRect);
procedure __PaintArrowDown(Canvas: TCanvas; var Rect: TRect);
 
....y la implementación....
 
// Dibuja la línea hacia abajo
procedure TNeftaliDBGrid.__PaintArrowDown(Canvas: TCanvas; var Rect: TRect);
var
  APolyLine: Array[0..2] of TPoint;
  SaveCol, BrushCol : TColor;
begin
  // Utilizamos el canvas pasado como parámetro
  with Canvas do begin
    // Guardar los valores actuales
    SaveCol := Pen.Color;
    BrushCol := Brush.Color;
    // Activar los nuevos valores depintado
    Brush.Style := bsSolid;
    Pen.Color := Self.FixedColor;
    Brush.Color := Self.FixedColor;
    // Dibujar un rectágulo debajo para tapar el título
    Rectangle(Rect.Right-13, Rect.Top+3, Rect.Right-1, Rect.Top+15);
    // Dibujamos la flecha
    Pen.Color := clGray{clBlack};
    APolyLine[0]:=Point(Rect.Right-4, Rect.Top+5);
    APolyLine[1]:=Point(Rect.Right-11, Rect.Top+5);
    APolyLine[2]:=Point(Rect.Right-8, Rect.Top+11);
    PolyLine(APolyLine);
    Pen.Color := clWhite;
    MoveTo(Rect.Right-7, Rect.Top+11);
    LineTo(Rect.Right-4, Rect.Top+5);
    // Restaurar valores guardados
    Brush.Color := BrushCol;
    Pen.Color := SaveCol;
  end;
end;
 
// Dibuja la línea hacia arriba
procedure TNeftaliDBGrid.__PaintArrowUp(Canvas: TCanvas; var Rect: TRect);
var
  SaveCol, BrushCol : TColor;
begin
  // Utilizamos el canvas pasado por parámetro.
  with Canvas do begin
    // Guardar los valores de los colores
    SaveCol := Pen.Color;
    BrushCol := Brush.Color;
    // Nuevo estilo de pintado.
    Brush.Style := bsSolid;
    Pen.Color := Self.FixedColor;
    Brush.Color := Self.FixedColor;
    // Rectangulo por debajo para tapar el título
    Rectangle(Rect.Right-13, Rect.Top+3, Rect.Right-1, Rect.Top+15);
    // Dibujar la flacha
    Pen.Color := clGray{clBlack};
    MoveTo(Rect.Right-11, Rect.Top+11);
    LineTo(Rect.Right-8, Rect.Top+5);
    LineTo(Rect.Right-7, Rect.Top+5);
    Pen.Color:=clWhite;
    MoveTo(Rect.Right-7, Rect.Top+5);
    LineTo(Rect.Right-4, Rect.Top+11);
    LineTo(Rect.Right-11, Rect.Top+11);
    //Restaurar los colores
    Brush.Color := BrushCol;
    Pen.Color := SaveCol;
  end;
end;

Para poder pintar la flecha cuando te interese se debe redefinir el método para dibujar una celda existente en el TCustomDBGrid llamado DrawCell del componente de DBGrid estandard y añadir los dos métodos de dibujo a la parte privada:

procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
	            AState: TGridDrawState); override;
 
....y su implementación...
 
// Método para pintar una celda del DBGrid
procedure TNeftaliDBGrid.DrawCell(ACol, ARow: Integer; ARect: TRect;
	    AState: TGridDrawState);
begin
  inherited; // Importante la llamada al inherited
 
  // No es fila de títulos?
  if (ARow &lt;&gt; 0) then begin
    Exit;
  end;
 
  // Columna 3 (por ejemplo)
  if (ACol = 3) then begin
    __PaintArrowUp(Canvas, ARect);
  end;
 
  // Columna 4 (por ejemplo)
  if (ACol = 4) then begin
    __PaintArrowDown(Canvas, ARect);
  end;
end;

Y en la implementacion se hacen las comprobaciones de fila y columna, para que sólo pinte las flechas en la fila de títulos y en la columna que se desee. En éste ejemplo las columnas están como constantes, pero posiblemente se deberán obtener a partir de alguna variable/propiedad (por ejemplo la que el usuario pulse con el ratón. Puedes descargar el código de ejemplo del componente.

Download Descargar

Categories: Delphi, Trucos Tags: , , ,

Obtener la lista de procesos ejecutándose

domingo, 24 de febrero de 2008 1 comentario
Share Button

Con ésté trozo de código se puede obtener la lista de los procesos (nombre del ejecutable) que están en marcha en ese momento en la máquina:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
var
  i: Integer;
  bContinue: BOOL;
begin
   // Limpiar la lista
   ListBox1.Items.Clear;
   // Recoge la lista de procesos en éste momento
   aSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
   aProcessEntry32.dwSize := SizeOf(aProcessEntry32);
   // Acceder al primer proceso
   bContinue := Process32First(aSnapshotHandle, aProcessEntry32);
   // Recorerr los procesos activos
   while (Integer(bContinue) <> 0) do begin
      // Añadirlo a la lista
      ListBox1.Items.Add(ExtractFileName(aProcessEntry32.szExeFile));
      // Hay más?
      bContinue := Process32Next(aSnapshotHandle, aProcessEntry32);
   end;
   // cerrar la estructura
   CloseHandle(aSnapshotHandle);

Utilizando aProcessEntry32 se puede obtener más información de cada uno de los procesos, como:

* Identificador
* Nombre competo
* …

IntToHex(aProcessEntry32.th32ProcessID, 4)
aProcessEntry32.szExeFile

Categories: Delphi, Trucos Tags: , , ,

Mover controles de un form en Runtime

sábado, 2 de febrero de 2008 2 comentarios
Share Button

Creando tres sencillos procedimientos en un formulario se pueden mover controles visuales en Runtime colocados en un form siempre que deriven de TControl. Basta con definir los siguientes procedimientos y asignarlos a todos los controles que queramos mover; Además se deben definir dos variables en la parte privada del form:

NOTA: Los procedimientos se deben definir no en la parte privada, sino como eventos del form.

En la parte final de artículo se puede descargar un ejemplo compilado con Delphi 6.

  • procedure MouseMove;
  • procedure MouseUp;
  • procedure MouseDown;
// Definirlos como ventos del form
procedure MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure MouseUp(Sender: TObject; Button: TMouseButton; 
                           Shift: TShiftState; X, Y: Integer);
procedure MouseDown(Sender: TObject; Button: TMouseButton; 
                               Shift: TShiftState; X, Y: Integer);
 
...
 
// Definir éstas variables en la parte privada...
private
  Capturing:Boolean;
  MouseDownSpot:TPoint;
 
....
 
// IMPLEMENTACION
// Procedimintos a asignar a los eventos de los controles...
procedure TForm1.MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
begin
  // Estamos capturando?
  if Capturing then begin
    // Mover el componente
    TControl(Sender).Left := TControl(Sender).Left - (MouseDownSpot.x - x);
    TControl(Sender).Top := TControl(Sender).Top - (MouseDownSpot.y - y);
  end;
end;
 
 
procedure TForm1.MouseUp(Sender: TObject; Button: TMouseButton; 
                            Shift: TShiftState; X, Y: Integer);
begin
  // Estamos capturando?
  if Capturing then begin
    ReleaseCapture; // Liberar la captura
    Capturing := false;
    TControl(Sender).Left := TControl(Sender).Left - (MouseDownSpot.x - x);
    TControl(Sender).Top := TControl(Sender).Top - (MouseDownSpot.y - y);
  end;
end;
 
procedure TForm1.MouseDown(Sender: TObject; Button: TMouseButton; 
                                          Shift: TShiftState; X, Y: Integer);
begin
  // Comenzar la captura y movimiento
  Capturing := true;
  MouseDownSpot.X := x;
  MouseDownSpot.Y := Y;
end;

Se puede descargar un ejemplo:

Descargar

Categories: Delphi, Trucos Tags: , ,

Modificar propiedades de controles en ejecución utilizando RTTI

miércoles, 5 de diciembre de 2007 2 comentarios
Share Button

A veces durante la ejecución de código necesitamos modificar una determinada propiedad de diferentes tipos de controles. Para la explicación podemos pensar por ejemplo en como desactivar (Enabled=False) todos los controles de un formulario; Una primera opción podría ser un código como éste:

// recorrer los controles
for i := 0 to (Self.ComponentCount - 1) do begin
 
   // Es un Edit
   if (Components[i] is TEdit) then
   TEdit(Components[i]).Enabled := False;
   // Es un LAbel
   if (Components[i] is TLabel) then
   TLabel(Components[i]).Enabled := False;
   // Es un ListBox
   if (Components[i] is TListBox) then
   TListBox(Components[i]).Enabled := False;
   ...
end;

Una implementación como ésta tiene muchos problemas e inconvenientes; Los más claros podrían ser:* Es poco «ortodoxa», por decirlo así;

  • Es un código repetitivo y nada eficiente.
  • Es por definición incompleta, ya que el número de componentes que podemos tener en un form es inmenso y de muchas clases (yo sólo las básicas que trae Delphi).
  • Es poco flexible.

Utilizando RTTI podemos de forma relativamente sencilla modificar todos los componentes utilizando una única instrucción.
Podemos utilizar un procedimiento como éste:

{:Asigna valor a una propiedad a través del Nombre (RTTI). }
function SetPropAsString(AObj: TObject; const PropName, Value: String):Boolean;
var
   PInfo: PPropInfo;
begin
   // Intentamos acceder (con un puntero) a la info. de la propiedad
   PInfo := GetPropInfo(AObj.ClassInfo, PropName);
   Result := PInfo &lt;&gt; nil;
   // Se ha obtenido la información...
   if (Result) then begin
      // Se ha encontrado la propiedad con éste nombre; Chequear el tipo...
      if (PInfo^.Proptype^.Kind = tkString) or
          (PInfo^.Proptype^.Kind = tkLString) then begin
        // Asignar el valor de tipo String
        SetStrProp(AObj, PInfo, Value);
      end
      else if (PInfo^.Proptype^.Kind = tkInteger) then begin
        // Asignar el valor...
        if (PInfo^.PropType^.Name = 'TColor') then begin
          SetOrdProp(AObj, PInfo, StringToColor(Value));
        end
      else if (PInfo^.PropType^.Name = 'TCursor') then begin
        SetOrdProp(AObj, PInfo, StringToCursor(Value));
      end
      else begin
        SetOrdProp(AObj, PInfo, StrToInt(Value));
      end;
   end
   else if (PInfo^.Proptype^.Kind = tkEnumeration) then begin
    // Bloque de proteccion
    try
      if (PInfo^.PropType^ = TypeInfo(System.Boolean)) then begin
        SetOrdProp(AObj, PInfo, StrToInt(Value));
      end
      else begin
        SetOrdProp(AObj, PInfo, StrToInt(Value));
      end;
    except
      raise;
    end;
   end
   else begin
    Result := False;
   end;
  end
  else begin
    // No se ha encontrado la propiedad con ese nombre
    Result := False;
  end;
end;

Su utilización es muy sencilla, y en el ejemplo anterior el código utilizado pasaría a ser similar a éste:

NOTA: Añadir la unit TypInfo al USES.

NOTA2: (Gracias Arsenio por comentarmelo) Se deben añadir al uses también las units Graphics y Controls ya que son usados por StringToColor y StringToCursor respectivamente.

// recorrer los controles
for i := 0 to (Self.ComponentCount - 1) do begin
   SetPropAsString(Components[i], 'Enabled', '0'{FALSE});
end;
// Otros ejemplos
SetPropAsString(Components[i], 'Left', '10');
SetPropAsString(Components[i], 'Color', 'clRed');
...
Categories: Delphi, Trucos Tags: , , ,

«Pasar» uno o varios ítems de un menú a la parte derecha

sábado, 1 de diciembre de 2007 Sin comentarios
Share Button

A veces es interesante poder situar una o varias opciones de un menú a la parte derecha, como una forma de diferenciarlas de las demás o por una característica púramente estética.
Utilizando el siguiente procedimiento se pueden mover uno o varios ítems.

Definimos un menú y sus ítems de la forma estandard en Delphi. Llamamos a éste procedimiento (en el OnShow del formulario por ejemplo) con el menú como parámetro y en índice del elemento que queremos «mover» a la parte derecha; ese y los siguiente serán desplazados a la parte derecha de la zona del título.

Ej: Total Commander, por ejempo, utiliza ésta característica con el menú ade ayuda:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
{:Pasa un item de menú a la derecha de la pantalla.
Pasa un item de menú y todos los que hay a su derecha a la parte "derecha" de
la barra de menús del formulario.}
procedure MenuItemAtRight (MainMenu:TMainMenu; Position:Integer);
var
   Handle:HMENU;
   MenuItemInfo:TMenuItemInfo;
   Buffer: array[0..79] of char;
begin
   // Coger el handle del menu principal
   Handle := MainMenu.Handle;
 
   // Rellenar estructura
   FillChar (MenuItemInfo, SizeOf(TMenuItemInfo), 0);
   MenuItemInfo.cbSize := SizeOf(TMenuItemInfo);
   MenuItemInfo.fMask := MIIM_TYPE;
   MenuItemInfo.dwTypeData := Buffer;
   MenuItemInfo.cch := SizeOf(Buffer);
 
   // No se puede obtener la informacion del item del menú ?
   if not GetMenuItemInfo(Handle, Position, True, MenuItemInfo) then begin
    // salir
    Exit;
   end;
 
   // Modificar el tipo de menú para ponerlo a la derecha
   MenuItemInfo.fType := MenuItemInfo.fType or MF_RIGHTJUSTIFY;
 
   // No se puede establecer informacion del item de menú
   if not SetMenuItemInfo (Handle, Position, True, MenuItemInfo) then begin
     Exit;
   end;
end;

Puedes llamar a ésta funcioón de la siguiente forma:

1
2
3
4
5
// Para poner el tercer eleento y los siguientes:
MenuItemAtRight(Self.MainMenu1, 3);
// Para poner el último elemento:
MenuItemAtRight(Self.MainMenu1,
Windows.GetMenuItemCount(Self.MainMenu1.Handle)-1);
Categories: Delphi, Trucos Tags: , , ,

Acceder a las propiedades de un componente vía RTTI

jueves, 8 de noviembre de 2007 Sin comentarios
Share Button

Éste truco aparece debido a la necesidad de obtener vía RTTI la siguiente información: Lista de todas las propiedades de un componente.

Valor de una propiedad de un componente sin utilizar el método siguiente (*).
Una primera aproximación para obtener la propiedad (Left, por ejemplo) de un componente del que a priori no conocemos el tipo, es utilizar una estructura IF o CASE (método 1) similar a la siguiente:

1
2
3
4
5
6
7
8
// Metodo 1 (*)
// Segun el tipo de componente...
if (comp is TEdit) then
  Result := TEdit(comp).Left;
else if (comp is TLabel) then
  Result := TLabel(comp).Left;
else if (comp is TButton) then
  Result := TButton(comp).Left;

Está claro que éste método es poco eficiente, poco flexible (siempre podemos dejarnos algún tipo de componente) y poco ortodoxo.
¿Cómo debe hacerlo Delphi para mostrar las propiedades de un componente en el inspector de objetos (por ejemplo)?

La respuesta es RTTI. Se puede acceder a las propiedades de un componente (a partir de la clase) y del nombre de la propiedad, utilizando la siguiente función (he añadido un parámetro nuevo para obtener en la misma llamada la lista de todas las propiedades -TStrings-).

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
{:Obtener la información de una propiedad a partir de la clase y el nombre;
Ademas devuelve la lista de todas las porpiedades de ese control.}
function GetRTTIControlInfo(AControl: TPersistent;
         propList:TStrings;  AProperty: string): PPropInfo;
var
   i: integer;
   props: PPropList;
   tData: PTypeData;
begin
   // Inicial
   Result := nil;
   // No asignado el control ==> Salimos
   if (AControl = nil) or (AControl.ClassInfo = nil) then begin
      Exit;
   end;
   // Obtener la información
   tData := GetTypeData(AControl.ClassInfo);
   // Tipo desconocido o sin propiedades ==> Salimos
   if (tData = nil) or (tData^.PropCount = 0) then
   	Exit;
    GetMem(props, tData^.PropCount * SizeOf(Pointer));
    try
   	GetPropInfos(AControl.ClassInfo, props);
 	for i := 0 to tData^.PropCount - 1 do begin
   		propList.Add(Props^[i]^.Name);
   		with Props^[i]^ do begin
    		  if (Name = AProperty) then begin
		   	result := Props^[i];
	   	  end;
   	        end;
   	end;
   finally
      FreeMem(props);
   end;
end;

Un ejemplo de utilización podría ser el siguiente:
(basta con un formulario que tenga un TButton y un TMemo)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
procedure TForm1.Button1Click(Sender: TObject);
var
  pInfo: PPropInfo;
  propList:TStrings;
  PStr:String;
begin
 // Crear la lista
 propList := TStringList.Create();
 // protección para liberar
 try
 
  // Acceder a la info de la propiedad
  pInfo := GetRTTIControlInfo(Button1, propList, 'Left');
  // La prop. encontrada es de tipo integer (debería ser, ya que es la
  // prop. Left)
  if (pInfo.PropType^^.Kind in [tkInteger]) then begin
    // Obtener
    PStr:= 'Left' + ' = ' + Format('%d', [GetOrdProp(Button1, pInfo)]);
    // Mostrar
    MessageDlg(PStr, mtInformation, [mbOK], 0);
  end;
  // Rellenar la lista de propiedades
  Memo1.Lines.Assign(propList);
 finally
    FreeAndNil(propList);
 end;
end;
Categories: Delphi, Trucos Tags: , , ,

Crear campos en una tabla (Access) por código, utilizando ADOX

jueves, 8 de noviembre de 2007 Sin comentarios
Share Button

En este ejemplo vamos a crear un par de campos de tipo String, una clave primaria y un campo de tipo entero y Autonumérico (Autoincremental) para probar las propiedades de ADOX:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
var
   Catalog : _Catalog;
   Table : _Table;
   BaseName : String;
   DS : String;
   col : _Column;
   key : _Key;
begin
   // Nombre de la Base de Datos
   BaseName := 'C:\Temp\MiBaseDatos.mdb';
   // Create a Catalog Object
   Catalog := CreateCOMObject(StringToGUID('ADOX.Catalog')) 
                  as  _Catalog;
   // Set the Connection String
   DS := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+BaseName;
   // Check if we already have such a file and delete it
   if FileExists(BaseName) Then begin
      DeleteFile(BaseName);
   end;
   // Create new Access database
   Catalog.Create(DS);
   // Create a Table Object
   Table := CreateCOMObject(StringToGUID('ADOX.Table')) as _Table;
   // Set the name of a table
   Table.Name := 'MiTabla';
   // Append Table into the base
   Catalog.Tables.Append(Table);
   // Now add two columns (fields) into the table
   // Both are Text fields up to 128 characters
   Table.Columns.Append('Nombre', adVarWChar, 128);
   Table.Columns.Append('Apellido', adVarWChar, 128);
   // Creamos el objeto columna para el autoIncremental
   col := CoColumn.Create;
   // BD a la que pertenece
   col.ParentCatalog := Catalog;
   col.Name := 'Auntoincremental';
   // Tipo del campo
   col.Type_ := adInteger;
   // Asignamos que es un AutoIncremental
   col.Properties['AutoIncrement'].Value := True;
   // Añadimos la columna
   Table.Columns.Append(col, adInteger, col.DefinedSize);
   // Columna para la clave primaria
   col := CoColumn.Create;
   // BD a la que pertenece
   col.ParentCatalog := Catalog;
   col.Name := 'ClavePrimaria';
   col.Type_ := adInteger;
   // Añadirla
   Table.Columns.Append(col, adInteger, col.DefinedSize);
   // Creamos la clave primaria
   Key := CoKey.Create;
   Key.Name := 'ClavePrimaria';
   Key.Type_ := adKeyPrimary;
   // Columna que forma parte de la PK
   Key.Columns.Append('ClavePrimaria', adInteger, 0 );
   // Añadirla a la tabla
   Table.Keys.Append(Key, 0, EmptyParam, Unassigned, Unassigned);

Primero se crea la tabla, posteriormente se crean los objetos columna (coColumn) y se modifican sus propiedades, para finalmente añadirlo a la tabla. Finalmente se crea el objeto coKey para definir la clave primaria, se añade la columna que la compone y este objeto se añade también a la tabla creada.

Categories: Delphi, Trucos Tags: , , , , ,