/*Prog*/ Delphi-Neftalí /*finProg*/

procedure TFormMain.Button1Click(Sender: TObject);
var
  i:integer;
  str:string;
 
  // Recursiva para obtener los subItems
  procedure GetItems(mi:TMenuItem);
  var
    i:Integer;
  begin
    for i := 0 to (mi.Count - 1) do begin
      Str := mi.Items[i].Caption;
      ListBox1.Items.AddObject(Str, mi.Items[i]);
      // SubItems de este
      GetItems(mi.Items[i]);
    end;
  end;
begin
 
  // Recorerr menu principal
  for i := 0 to (MainMenu1.Items.Count - 1) do begin
    Str := MainMenu1.Items[i].Caption;
    ListBox1.Items.AddObject(Str, MainMenu1.Items[i]);
    // SubItems de este
    GetItems(MainMenu1.Items[i]);
  end;
end;

procedure TFormMain.Button2Click(Sender: TObject);
var
  img:TImage;
  mi:TMenuItem;
begin
  If  ListBox1.ItemIndex = -1 then begin
    MessageDlg('Selecciona un elemento de la llista', mtWarning, [mbOK], 0);
    Exit;
  end;
 
  // Item del menu
  mi := TMenuItem(ListBox1.Items.Objects[ListBox1.ItemIndex]);
 
  // Tiene asignado el OnClick?
  if Assigned(mi.OnClick) then begin
    // Nada
  end
  else begin
    // Tiene asignada la action?
    if Assigned(mi.Action) then begin
      //signado OnExecute
      if Assigned(mi.Action.OnExecute) then begin
        // Nada
      end
      else begin
        MessageDlg('Ese elemento no tiene nada que hacer asignado',
             mtWarning, [mbOK], 0);
        Exit;
      end;
    end
    else begin
      MessageDlg('Ese elemento no tiene nada que hacer asignado',
             mtWarning, [mbOK], 0);
      Exit;
    end;
  end;
 
  Randomize;
 
  // Elemento seleccionado
  img := TImage.Create(nil);
  img.Parent := Panel1;
  img.Height := 32;
  img.Width := 32;
  img.Left := Random(panel1.Width - img.Width);
  img.Top := Random(panel1.Height - img.Height);
  img.Stretch := True;
  img.Transparent := True;
  // El TAG es la posicion en la lista
  img.Tag := ListBox1.ItemIndex;
  // Item del menu
  mi := TMenuItem(ListBox1.Items.Objects[ListBox1.ItemIndex]);
  // Asignar la imagen
  ImageList1.GetBitmap(mi.ImageIndex, img.Picture.Bitmap);
  // Asignar el evento
  img.OnClick := MyImgClick;
end;

var
  i:integer;
  str:string;
  mi:TMenuItem;
begin
  // Test del sender
  if not (sender is TImage) then begin
    Exit;
  end
  else begin
    i := TImage(Sender).Tag;
    Str := ListBox1.Items[i];
  end;
 
  // Acceder a la opción de menú
  mi := TMenuItem(ListBox1.Items.Objects[i]);
  // Asignado código?
  if Assigned(mi.OnClick) then begin
    mi.OnClick(nil);
    Exit;
  end
  else begin
    // Tiene asignada la action?
    if Assigned(mi.Action) then begin
      // Asignado OnExecute
      if Assigned(mi.Action.OnExecute) then begin
        mi.Action.OnExecute(nil);
        Exit;
      end;
    end
  end;
 
  MessageDlg('No hay nada asignado a esa opción...', mtInformation, [mbOK], 0);
end;

// Grabar
ini.WriteString(CONFIG_SECTION, 'User', edtUser.Text);
ini.WriteString(CONFIG_SECTION, 'password', edtPassword.Text);
ini.WriteString(CONFIG_SECTION, 'Server', edtServer.Text);
ini.WriteString(CONFIG_SECTION, 'BaseDatos', cbBD.Text);

// Cargar datos
edtUSer.Text := ini.ReadString(CONFIG_SECTION, 'User', STR_EMPTY);
edtPassword.Text := ini.ReadString(CONFIG_SECTION, 'password', STR_EMPTY);
edtServer.Text := ini.ReadString(CONFIG_SECTION, 'Server', STR_EMPTY);
cbBD.Text := ini.ReadString(CONFIG_SECTION, 'BaseDatos', STR_EMPTY);

const
STR_CONN = 'Provider=SQLOLEDB.1;Password=%s;Persist Security Info=True;' +
'User ID=%s;Initial Catalog=%s;Data Source=%s';
 
...
 
// Intentar conectar
ADOConnection1.ConnectionObject.ConnectionString :=
Format(STR_CONN, [edtPassword.Text, edtUser.Text, cbBD.Text, edtServer.Text]);

SELECT * FROM SysDataBases

// Esta otra mantiene la relacion entre alto y ancho
procedure Proporcional(Imagen: TGraphic; Ancho, Alto: Integer);
var
  Bitmap: TBitmap;
  Rect:TRect;
begin
  Bitmap:= TBitmap.Create;
  try
    Bitmap.Width:= Ancho;
    Bitmap.Height:= Alto;
 
    /// Calculos para que quede proporcional
    if  (Ancho/Imagen.Width) < (Alto/Imagen.Height) then  begin
      Alto:= Trunc((Ancho*Imagen.Height)/Imagen.Width);
    end
    else begin
      Ancho:= Trunc((Imagen.Width*Alto)/Imagen.Height);
    end;
 
    // posición nueva
    // Hay que centarla para que queden márgenes iguales a ambos lados
    Rect.Left := ((Bitmap.Width - Ancho) div 2);
    Rect.Top := ((Bitmap.Height - Alto) div 2);
    Rect.Right:= Rect.Left + Ancho;
    Rect.Bottom := Rect.Top + Alto;
 
    // Color neutro para márgenes
    Bitmap.Canvas.Brush.Color := clRed;
    // copiar
    Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);
    Bitmap.Canvas.StretchDraw(Rect,Imagen);
    Imagen.Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
end;

// Esta cambia el alto y ancho, estirando la imagen si es necesario
procedure Redimensionar(Imagen:TBitmap; Ancho, Alto: Integer);
var
  Bitmap: TBitmap;
begin
 
  Bitmap:= TBitmap.Create;
 
  // Aplicamos antialiasing
  Antialiasing(Imagen, Bitmap);
  Imagen.Assign(Bitmap);
 
  // reducir
  try
    Bitmap.Width:= Ancho;
    Bitmap.Height:= Alto;
    Bitmap.Canvas.StretchDraw(Bitmap.Canvas.ClipRect, Imagen);
    Imagen.Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
end;

  // R1 es el componente Red del pixel actual y R2 y R3 los del sup. e inferior.
  R1:=Round(R1 + R2 + R3 ) div 3;
  G1:=Round(G1 + G2 + R3 ) div 3;
  B1:=Round(B1 + B2 + b3 ) div 3;
  // color resultante
  Result := RGB(R1,G1,B1);

type
  TRGBTripleArray = array[0..32767] of TRGBTriple;
  PRGBTripleArray = ^TRGBTripleArray;
...
// Esta cambia el alto y ancho, estirando la imagen si es necesario
procedure Redimensionar(Imagen:TBitmap; Ancho, Alto: Integer);
var
  Bitmap: TBitmap;
  //····························································
  // Procedimiento de Antialiasing con Distancia=1
  procedure Antialiasing(bmp1, bmp2:TBitmap);
  var
    r1,g1,b1:Integer;
    Y, X, j:integer;
    SL1, SL2, SL3: PRGBTripleArray;
  begin
 
    // Tamaño del bitmap destino
    bmp2.Height := bmp1.Height;
    bmp2.Width := bmp1.Width;
    // SCANLINE
    SL1 := bmp1.ScanLine[0];
    SL2 := bmp1.ScanLine[1];
    SL3 := bmp1.ScanLine[2];
 
    // reorrido para todos los pixels
    for Y := 1 to (bmp1.Height - 2) do begin
      for X := 1 to (bmp1.Width - 2) do begin
        R1 := 0;  G1 := 0; B1 := 0;
        // los 9 pixels a tener en cuenta
        for j := -1 to 1 do begin
          // FIla anterior
          R1 := R1 + SL1[X+j].rgbtRed    + SL2[X+j].rgbtRed    + SL3[X+j].rgbtRed;
          G1 := G1 + SL1[X+j].rgbtGreen  + SL2[X+j].rgbtGreen  + SL3[X+j].rgbtGreen;
          B1 := B1 + SL1[X+j].rgbtBlue   + SL2[X+j].rgbtBlue   + SL3[X+j].rgbtBlue;
        end;
        // Nuevo color
        R1:=Round(R1 div 9);
        G1:=Round(G1 div 9);
        B1:=Round(B1 div 9);
        // Asignar el nuevo
        bmp2.Canvas.Pixels[X, Y] := RGB(R1,G1,B1);
      end;
      // Siguientes...
      SL1 := SL2;
      SL2 := SL3;
      SL3 := bmp1.ScanLine[Y+1];
    end;
  end;
  //····························································  
begin
 
  Bitmap:= TBitmap.Create;
 
  // Aplicamos antialiasing
  Antialiasing(Imagen, Bitmap);
  Imagen.Assign(Bitmap);
 
  // reducir
  try
    Bitmap.Width:= Ancho;
    Bitmap.Height:= Alto;
    Bitmap.Canvas.StretchDraw(Bitmap.Canvas.ClipRect, Imagen);
    Imagen.Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
end;

// Capturar mensajes al form
procedure WMSysCommand(var Msg: TWMSysCommand);
            message WM_SYSCOMMAND;

// Capturar mensajes....
procedure TFormMain.WMSysCommand(var Msg: TWMSysCommand);
begin
  // Minimizando?
  if (Msg.CmdType = SC_MINIMIZE) then begin
    actionOcultar.Execute;
  end
  else begin
    DefaultHandler(Msg);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
const
  DB_CONNECTION='Provider=Microsoft.Jet.OLEDB.4.0;' + 
       'Data Source=%s'; 
  DATABASENAME = 'c:\Archivos de ' +
       'programa\Archivos comunes\Borland Shared\Data' + 
       '\dbdemos.mdb';
var
  i, j:Integer;
  Con:OleVariant;
  fCatalog:Catalog;
  Column: _Column;
  Table:_Table;
  Str1, Str2:string;
begin
  // Limpiar la salida
  Memo1.Lines.Clear;
  // Conectar con la Base de Datos
  Con := CreateOleObject('ADODB.Connection');
  // Abrir
  Con.Open(Format(DB_CONNECTION,[DATABASENAME]));
  // proteccion
  try
    // Acceder a la Base de Datos
    fCatalog := CoCatalog.Create;
    fCatalog._Set_ActiveConnection(Con);
    // Acceder a la tabla de empleados
    Table := fCatalog.Tables['employee'];
    // recorrer las columnas
    for i := 0 to (Table.Columns.Count - 1) do begin
      // Acceder a la columna
      Column := Table.Columns[i];
      // Datos de columna
      Memo1.Lines.Add(' ');
      Memo1.Lines.Add(Format('Columna: %s',[Column.Name]));
      Memo1.Lines.Add('---------------------------------');
      Memo1.Lines.Add(Format(' Tamaño: %d',[Column.DefinedSize]));
      Memo1.Lines.Add(Format(' Precisión: %d',[Column.Precision]));
      // recorrer las propiedades de la columna
      for j := 0 to (Column.Properties.Count - 1) do begin
        // Cada propiedad, Nombre y valor
        Str1 := Column.Properties[j].Name;
        Str2 := Column.Properties[j].Value;
        // Saltamos las propiedades Jet...
        if (Length(Str1) > 0) then begin
          // Saltar las Jet
          if (Str1[1] <> 'J') then begin
            Memo1.Lines.Add(Format(' %s: %s',[Str1, Str2]))
          end; //if
        end; //if
      end; // for
    end; // for
  finally
    // Liberar y cerrar
    Column := nil;
    Table := nil;
    fCatalog := nil;
    Con.Close;
  end;
end;

// Ordena un TStringGrid.
procedure SortStringGrid(var GenStrGrid: TStringGrid;
    ThatCol: Integer;
    ColData:TGridData=gdString;
    SortOrder:TSortOrder=soASC);
const
  TheSeparator = '@';
var
  CountItem, I, J, K, ThePosition: integer;
  MyList: TStringList;
  MyString, TempString: string;
  str:string;
  vali:Integer;
  valf:Double;
begin
  CountItem := GenStrGrid.RowCount;
  MyList := TStringList.Create;
  MyList.Sorted := False;
  try
    begin
      for I := 1 to (CountItem - 1) do begin
        Str := GenStrGrid.Rows[I].Strings[ThatCol];
        if (ColData = gdInteger) then begin
          vali := StrToIntDef(Str, 0);
          Str := Format('%*d', [15,vali]);
        end;
        if (ColData = gdFloat) then begin
          valf := StrToFloat(Str);
          Str := Format('%15.2f',[valf]);
        end;
        MyList.Add(Str + TheSeparator + GenStrGrid.Rows[I].Text);
      end;
      Mylist.Sort;
 
      for K := 1 to Mylist.Count do begin
        MyString := MyList.Strings[(K - 1)];
        ThePosition := Pos(TheSeparator, MyString);
        TempString := '';
        {Eliminate the Text of the column on which we have
          sorted the StringGrid}
        TempString := Copy(MyString, (ThePosition + 1), Length(MyString));
        MyList.Strings[(K - 1)] := '';
        MyList.Strings[(K - 1)] := TempString;
      end;
 
      if (SortOrder = soASC) then begin
        for J := 1 to (CountItem - 1) do begin
            GenStrGrid.Rows[J].Text := MyList.Strings[(J - 1)];
        end;
      end
      else begin
        for J := 1 to (CountItem - 1) do begin
          I := (CountItem - J);
          GenStrGrid.Rows[I].Text := MyList.Strings[(J - 1)];
        end;
      end;
    end;
 
  finally
    MyList.Free;
  end;
end;

Type
  //: Tipo de Dat de la columna por la que queremos ordenar.
  TGridData = (gdString, gdInteger, gdFloat);
  //: Tipos de ordenación.
  TSortOrder = (soASC, soDESC);

{: 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;

// 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;

// ================================================================
// 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;

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;