Autor Tema: Una pequeña colección de Trucos, Procedures y Funciones para Delphi  (Leído 13398 veces)

0 Usuarios y 1 Visitante están viendo este tema.

Desconectado RedPic

  • Administrador
  • DsPIC33
  • *****
  • Mensajes: 5388
    • Picmania by Redraven
Hay cientos de pequeñas cosas que tenemos que realizar en nuestros programas, aquí tenéis una pequeña colección de aquellas que he ido necesitando ... las he ido recopilando para lo que hagan falta:



Conocer el nombre de usuario del  Login de Windows.

function GetLoginName: string;
var
   buffer: array[0..255] of char;
   size: dword;
begin
   size := 256;
   if GetUserName(buffer, size) then
      Result := StrPas(buffer)
   else
      Result := StrPas('');
end;
 
   
Conocer el nombre de un ordenador en una Red Windows.

function GetComputerNetName: string;
var
   buffer: array[0..255] of char;
   size: dword;
begin
   size := 256;
   if GetComputerName(buffer, size) then
      Result := StrPas(buffer)
   else
      Result := StrPas('');
end;
 
   
Determinar los directorios de Instalación, Sistema y Archivos de Programas de Windows.

uses SysUtils, Windows;

El directorio de instalación de Windows

function GetWindowsDir: TFileName;
var
   WinDir: array [0..MAX_PATH-1] of char;
begin
   SetString(Result, WinDir, GetWindowsDirectory(WinDir, MAX_PATH));
   if Result = '' then
      raise Exception.Create(SysErrorMessage(GetLastError));
end;

El directorio de sistema de Windows

function GetSystemDir: TFileName;
var
   SysDir: array [0..MAX_PATH-1] of char;
begin
   SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH));
   if Result = '' then
      raise Exception.Create(SysErrorMessage(GetLastError));
end;

El directorio de los Archivos de Programa de Windows

function GetProgramFilesDir: TFileName;
begin
   Result := GetRegistryData(HKEY_LOCAL_MACHINE, '\Software\Microsoft\Windows\CurrentVersion', 'ProgramFilesDir');
end;
 
   
Calcular la letra de un DNI (España)

function NIF(DNI: String): Char;
begin
  Result := Copy('TRWAGMYFPDXBNJZSQVHLCKET',StrToInt(DNI) mod 23+1,1)[1];
end;
 
   
Calcular el dígito de control de un código EAN-13

function Calcula_digito_de_control_EAN13(CodS:string):integer;
var
   i,r,rd: integer;
   CodN: array[1..12] of integer;
   b: boolean;
begin
     // 1ª fase: calcula suma de digitos x 1 si impar, x 3 si par
     b := false; r := 0;
     for i := 1 to 12 do
     begin
       CodN[ i ] := 0;
       b := Not b;
       if b then
          CodN[ i ] := StrToInt(Copy(CodS,i,1)) * 1
       else
          CodN[ i ] := StrToInt(Copy(CodS,i,1)) * 3;
       r := r + CodN[ i ];
     end;
     rd := 0;
     // 2ª fase encuentra decena superior
     for i := r to r + 10 do
     begin
       if (i / 10) = Int(i / 10) then rd := i - r;
     end;
     if (rd = 10) then rd := 0;
     result := rd;
end;
   
Usar un FONT sin tener que instalarlo en Windows 

procedure TForm1.FormCreate(Sender: TObject);
begin
  AddFontResource('C:\FONTS\FUENTE.TTF');
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  RemoveFontResource('C:\FONTS\FUENTE.TTF');
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
 
   
Obtener el número de identificación de una tarjeta de red.

function GetNetworkID: string;
var
     G: TGuid;
begin
     OleCheck(CoCreateGuid(G));
     Result := GuidToString(G);
     Result := Copy(Result, Length(Result) - 12, 12);
end;
 
   
Ejecutar código antes de que mi aplicación sea minimizada.

type
 TForm1 = class(TForm)
 ...
 private
     procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
end;
...
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
   if (Msg.CmdType = SC_MINIMIZE) or
      (Msg.CmdType = SC_MAXIMIZE) then  MiCodigo;
   DefaultHandler(Msg);
end;
 
   
Obtener la información VersionInfo de tu ejecutable.

function GetAppInfo(De:string):string;
     {Se pueden pedir los siguientes datos:
     CompanyName
     FileDescription
     FileVersion
     InternalName
     LegalCopyright
     OriginalFilename
     ProductName
     ProductVersion
     }
type
     PaLeerBuffer = array [0..MAX_PATH] of char;
var
     Size, Size2 : DWord;
     Pt, Pt2 : Pointer;
     Idioma : string;
begin
     Result:='';
     Size := GetFileVersionInfoSize(PChar (Application.Exename), Size2);
     if Size > 0 then
     begin
       GetMem (Pt, Size);
       GetFileVersionInfo (PChar (ParamStr (0)), 0, Size, Pt);
       VerQueryValue( Pt, '\VarFileInfo\Translation',Pt2, Size2);
       Idioma:=IntToHex( DWord(Pt2^) ,8 );
       Idioma:=Copy(Idioma,5,4)+Copy(Idioma,1,4);
       VerQueryValue( Pt,Pchar('\StringFileInfo\'+Idioma+'\'+De),Pt2, Size2);
       if Size2 > 0 then
       begin
         Result:=Copy(PaLeerBuffer(Pt2^),1,Size2);
       end else
       raise Exception.Create( 'No existe esa informacion en este ejecutable');
       FreeMem (Pt);
     end else
     raise exception.Create ( 'Lo siento, no hay VersionInfo disponible en este ejecutable.');
end;
 
   
Hacer ReadOnly una sola columna de un TDBGrid.

procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
     if DBGrid1.SelectedField = MiCampoProtegido then
        DBGrid1.Options := DBGrid1.Options - [dgEditing]
     else
        DBGrid1.Options := DBGrid1.Options + [dgEditing];
end;
 
   
Cómo saber el PATH de una Base de Datos sabiendo su Alias

uses BDE;
.....
procedure ShowDatabaseDesc(DBName: String);
const
     DescStr = 'Driver Name: %s'#13#10'AliasName: %s'#13#10+Text: %s'#13#10'Physical Name/Path: %s';
var
     dbDes: DBDesc;
begin
     dbiGetDatabaseDesc(PChar(DBName), @dbDes);
     with dbDes do
          ShowMessage(Format(DescStr, [szDbType, szName, szText, szPhyName]));
end;
 
   
Cómo convertir TColor a HTML

Pon un TColorDialog (ColorDialog1), un TLabel (Label1) y un TButton (Button1) en tu form

Mete éste código en el OnClick de Button1:

procedure TForm1.Button1Click(Sender: TObject);
  function ColorToHtml(DelphiColor:TColor):string;
  var
    tmpRGB : TColorRef;
  begin
    tmpRGB := ColorToRGB(DelphiColor);
    Result:=Format( '#%.2x%.2x%.2x',[GetRValue(tmpRGB), GetGValue(tmpRGB), GetBValue(tmpRGB)]);
  end;
begin
    if ColorDialog1.Execute then
    Label1.Caption:=ColorToHtml(ColorDialog1.Color);
end;
 
   
Comprobar si una URL es válida

uses WinInet;
...
Function CheckUrl(url:string):boolean;
var
   hSession, hfile, hRequest: hInternet;
   dwindex,dwcodelen :dword;
   dwcode:array[1..20] of char;
   res : pchar;
begin
   if pos('http://',lowercase(url))=0 then
   url := 'http://'+url;
   Result := false;
   hSession := InternetOpen('InetURL:/1.0',
   INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
   if assigned(hsession) then
   begin
      hfile := InternetOpenUrl( hsession,  pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
      dwIndex := 0;
      dwCodeLen := 10;
      HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
      res := pchar(@dwcode);
      result:= (res ='200') or (res ='302');
      if assigned(hfile) then InternetCloseHandle(hfile);
      InternetCloseHandle(hsession);
   end;   
end;
 
   
Cómo saber el PATH correcto de mi aplicación

function TForm1.DirectorioAplicacion: string;
var
     Buffer: array [0..255] of Char;
begin
     GetModuleFileName(HInstance, Buffer, SizeOf(Buffer));
     Result := ExtractFilePath(StrPas(Buffer));
end;
   
Cómo saber si un formulario se ha movido.

interface
...
type
  TForm1 = class(TForm)
...
private
  { Private declarations }
  procedure FormMove(var Msg: TWMMove); message WM_MOVE;
...
end;
...
implementation
...
procedure TForm1.FormMove(var Msg: TWMMove);
begin
  inherited;
  Label1.Caption := Format('(%d,%d)', [Left, Top]);
end;
...
 
   
Detectar y confirmar el cierre de Windows

interface
...
type
  TForm1 = class(TForm)
...
private
  { Private declarations }
  procedure WMQueryEndSession(var Msg : TWMQueryEndSession); message WM_QueryEndSession;
...
end;
...
implementation
...
procedure TForm1.WMQueryEndSession(var Msg : TWMQueryEndSession);
begin
   if MessageDlg('¿Desea cerrar Windows?', mtConfirmation, [mbYes,mbNo], 0)  = mrNo  then
     Msg.Result := 0
   else
     Msg.Result := 1;
end;
...
   
Cómo ocultar o mostrar la Barra de tareas de Windows

procedure Ocultar_Barra;
begin
   ShowWindow(FindWindow( 'Shell_TrayWnd',nil), SW_HIDE);
end;
 
procedure Mostrar_Barra;
begin
   ShowWindow( FindWindow( 'Shell_TrayWnd',nil), SW_SHOWNA);
end;
 
   
Cómo registrar un tipo de fichero y el ejecutable que lo abre en Windows

procedure TForm1.FileFormatAssociations;
var
  reg: TRegistry;
  FileExt : String;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CLASSES_ROOT;
  reg.LazyWrite := false;
  FileExt := '.XYZ';
  //Borrar la Clave - Esto es importante !!!
  reg.OpenKey(FileExt, true);
  reg.WriteString('', FileExt);
  reg.CloseKey;
  //Invocamos al programa pasando el nombre del fichero como primer parámetro
  reg.OpenKey(FileExt + '\shell\open\command', true);
  reg.WriteString('', Application.ExeName + ' "%1"');
  reg.CloseKey;
  //El icono mostrado será el primer icono del ejecutable del programa
  reg.OpenKey(FileExt + '\DefaultIcon', true);
  reg.WriteString('', Application.ExeName + ',0');
  reg.CloseKey;
  reg.free;
end;
 
   
Quitar el Beep de un TEdit al pulsar [INTRO].

Generar el manejador de eventos OnKeyPress y escribir:
 if Key = #13 then Key := #0;
 
 
« Última modificación: 04 de Mayo de 2006, 02:03:53 por RedPic »
Contra la estupidez los propios dioses luchan en vano. Schiller
Mi Güeb : Picmania

Desconectado Nocturno

  • Administrador
  • DsPIC33
  • *******
  • Mensajes: 17482
    • MicroPIC
Re: Una pequeña colección de Trucos en Delphi
« Respuesta #1 en: 14 de Abril de 2006, 12:27:35 »
Gracias por la entrega Diego. Se ven muy útiles los ejemplos.
Un saludo desde Sevilla, España.
Visita MicroPIC                                                                                        ɔ!doɹɔ!ɯ ɐʇ!s!ʌ

Desconectado valdorre

  • Colaborador
  • PIC18
  • *****
  • Mensajes: 346
Re: Una pequeña colección de Trucos en Delphi
« Respuesta #2 en: 15 de Abril de 2006, 00:58:15 »
hola amigos, talvez ya conozcan esta pagina http://www.q3.nu/trucomania/index.html a mi me ayuda bastante cada vez que me trabo...
saludos
Osvaldo

Desconectado Delphus

  • PIC12
  • **
  • Mensajes: 70
Re: Una pequeña colección de Trucos, Procedures y Funciones para Delphi
« Respuesta #3 en: 30 de Octubre de 2011, 20:33:31 »
Gracias Redpic, me sirvió el de la versión del ejecutable.
Saludos


 

anything