Detectado javascript desactivado

Tienes el javascript desactivado en este momento. Muchas funciones podrían no funcionar. Por favor reactiva el javascript para obtener una funcionalidad completa.

Contenido con la más alta reputación

#98358 [MULTILENGUAJE] WM_MOUSELEAVE / WM_MOUSEENTER

Escrito por escafandra el 02 febrero 2017 - 02:54

El título lleva a engaño puesto que el mensaje WM_MOUSEENTER no existe aunque para casi todos, el concepto si.

Se trata de manejar los eventos OnMouseEnter y OnMouseLeave de una ventana en versiones Delphi antiguas que no implementan esta característica, al igual que en versiones Builder de la misma época. También servirá para usarlo con cualquier ventana sin necesidad de que se trate de un control - componente específico.

El mensaje WM_MOUSELEAVE es recibido por una ventana si preparó previamente su solicitud con una llamada a TrackMouseEvent. Simplemente informa que el cursor del ratón abandonó el área cliente de dicha ventana. Para detectar la presencia del cursor en la ventana (WM_MOUSEENTER) basta con gestionar WM_MOUSEMOVE.

Propongo una clase que habilita el tratamiento del mensaje WM_MOUSELEAVE recibido por cualquier ventana (incluidos componentes derivados de TControl) Para conseguirlo realiza un Hook a la función de tratamiento de mensajes realizando un subclassing que genere dos eventos: OnMouseLeave y OnMouseEnter.

Este sería el código de la Unit:

delphi

unit MouseLeave;
 
//--------------------------------------------------------------------------------------------------
// TMouseLeave (Versión Hook estilo C++)
// escafandra 2017
// Clase para manejo de WM_MOUSELEAVE de una ventana
 
interface
 
uses Windows, Messages;
 
type
  TOnMouseLeave = procedure(Handle: HWND) of object;
  TOnMouseEnter = procedure(Handle: HWND) of object;
 
type
  TMouseLeave = class
  private
    Handle: HWND;
    OldWndProc: Pointer;
    function WndProc(Handle: HWND; Msg: DWORD; WParam: Longint; LParam: Longint): Longint; stdcall;
  public
    OnMouseLeave: TOnMouseLeave;
    OnMouseEnter: TOnMouseEnter;
    constructor Create; overload;
    constructor Create(WND: HWND); overload;
    destructor Destroy; override;
    procedure  SetHandle(WND: HWND);
  end;
 
implementation
 
 
function DefWndProc(Handle: HWND; Msg: DWORD; WParam: Longint; LParam: Longint): Longint; stdcall;
var
  pMouseLeave: TMouseLeave;
begin
  pMouseLeave:= TMouseLeave(GetWindowLong(Handle, GWL_USERDATA));
  if pMouseLeave <> nil then
    Result:= pMouseLeave.WndProc(Handle, Msg, WParam, LParam)
  else
    Result:= DefWindowProc(Handle, Msg, WParam, LParam);
end;
 
constructor TMouseLeave.Create;
begin
  OnMouseLeave:= nil;
  OnMouseEnter:= nil;
  SetHandle(0);
end;
 
constructor TMouseLeave.Create(WND: HWND);
begin
  OnMouseLeave:= nil;
  OnMouseEnter:= nil;
  SetHandle(WND);
end;
 
function TMouseLeave.WndProc(Handle: HWND; Msg: DWORD; WParam: Longint; LParam: Longint): Longint; stdcall;
var
  TE: TTRACKMOUSEEVENT;
begin
  if (Msg = WM_MOUSELEAVE) and (@OnMouseLeave <> nil) then
    OnMouseLeave(Handle)
 
  else if (Msg = WM_MOUSEMOVE) and (@OnMouseEnter <> nil) then
  begin
    TE.cbSize:= sizeof(TTRACKMOUSEEVENT);
    TE.dwFlags:= TME_LEAVE;
    TE.hwndTrack:= Handle;
    TE.dwHoverTime:= HOVER_DEFAULT;
    TrackMouseEvent(TE);
    OnMouseEnter(Handle);
  end;
  Result:= CallWindowProc(OldWndProc, Handle, Msg, WParam, LParam);
end;
 
 
procedure TMouseLeave.SetHandle(WND: HWND);
begin
  if (WND <> INVALID_HANDLE_VALUE) and (WND <> Handle) then
  begin
    if WND = 0 then
    begin
      SetWindowLong(Handle, GWL_USERDATA, 0);
      SetWindowLong(Handle, GWL_WNDPROC, LongInt(OldWndProc));
    end;
    if WND <> 0 then
    begin
      SetWindowLong(WND, GWL_USERDATA, LongInt(self));
      OldWndProc:= Pointer(SetWindowLong(WND, GWL_WNDPROC, LongInt(@DefWndProc)));
    end;
    Handle:= WND;
  end;
end;
 
destructor TMouseLeave.Destroy;
begin
  OnMouseLeave:= nil;
  OnMouseEnter:= nil;
  SetHandle(0);
end;
 
end.

Un ejemplo de uso con un botón, coloco la Unit completa para mostrar todos los pasos de uso y declaración de los eventos:

delphi

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, MouseLeave;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    ME: TMouseLeave;
    procedure OnMouseLeave(Wnd: HWND);
    procedure OnMouseEnter(Wnd: HWND);
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  ME:= TMouseLeave.Create(Button1.Handle);
  ME.OnMouseEnter:= OnMouseEnter;
  ME.OnMouseLeave:= OnMouseLeave;
end;
 
procedure TForm1.OnMouseLeave(Wnd: HWND);
begin
  with FindControl(Wnd) as TButton do Caption:= 'Adios';
end;
 
procedure TForm1.OnMouseEnter(Wnd: HWND);
begin
  with FindControl(Wnd) as TButton do Caption:= 'Hola';
end;
 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ME.Free;
end;
 
end.

Se precisa crear tantos objetos TMouseLeave como ventanas a controlar.

Subo el código.

Saludos.

Archivos adjuntos

MouseLeave_Delphi.zip 191,96KB 7 descargas

#91149 Jugando con las conexiones Wifi

Escrito por escafandra el 14 septiembre 2015 - 12:04

Prometí ampliar este tema, en esta ocasión añado varias funcionalidades nuevas:

1- Notificaciones de lo que sucede con la WIFI con apoyo de función callback: API WlanRegisterNotification

2- Información del cifrado de clave y de red.

3- Posibilidad de conectarse a una red Wifi no añadida en el PC identificándonos con su SSID y Clave.

4- Posibilidad de conectarse a una red abierta.

5. Extracción de la clave de una SSID específica.

6- Extracción de todas las claves de la lista de redes wifi memorizada en el PC.

7- Funciones extra,

8- Notificaciones en el SysTray.

9- Aumento definiciones de la API Native Wifi Functions en una unit por separado.

Como el código es largo, lo incluyo en un nuevo adjunto.

Saludos.

Archivos adjuntos

WiffiConnect2.rar 171,63KB 88 descargas

#91022 Jugando con las conexiones Wifi

Escrito por escafandra el 06 septiembre 2015 - 10:56

He estado jugando un poco con las interfaces y conexiones wifi y el resultado es una pequeña aplicación que muestra las redes wifi disponibles y nos conecta a una si tenemos configurada su autentificación.

La base del ejercicio es la API Native Wifi Functions. En delphi 7 habrá que definir unas cuantas estructuras tomadas de la documentación de M$ y adaptadas para simplificar las cosas, no se si en las últimas versiones de delphi están incluidas estas definiciones.

El programita hace una lista de las redes disponibles escaneando los adaptadores wifi presentes en el PC, luego, conociendo el nombre de la Wifi a conectarnos, nos conecta. He incluido una desconexión rápida de todos los adaptadores.

El corazón del código es este:

delphi

type
  TWifiData = record
    InterfaceInfo: String;
    Profile: String;
    SSID: String;
    Signal: integer;
    Auth: String;
    Conected: BOOL;
  end;
 
 
function WifiScan(var List: array of TWifiData): integer;
const
  AuthStr: array [1..9]of String = ('Open','Shared Key','WPA','WPA-PSK','WPA NONE','RSNA','RSNA-PSK','IHV Start','IHV End');
var
  hClient: THandle;
  dwVersion: DWORD;
  pInterfaceInfoList: PWLAN_INTERFACE_INFO_LIST;
  pInterfaceGuid: PGUID;
  pNetworkList: PWLAN_AVAILABLE_NETWORK_LIST;
  i, j: integer;
begin
  Result:= 0;
  if ERROR_SUCCESS = WlanOpenHandle(1, nil, @dwVersion, @hClient) then
  begin
    if ERROR_SUCCESS = WlanEnumInterfaces(hClient, nil, @pInterfaceInfoList) then
    begin
      for i := 0 to pInterfaceInfoList^.dwNumberOfItems - 1 do
      begin
        pInterfaceGuid:= @pInterfaceInfoList^.InterfaceInfo[pInterfaceInfoList^.dwIndex].InterfaceGuid;
        if ERROR_SUCCESS = WlanGetAvailableNetworkList(hClient, pInterfaceGuid, 1, nil, pNetworkList) then
        begin
          for j := 0 to pNetworkList^.dwNumberOfItems - 1 do
          begin
            Result:= pNetworkList^.dwNumberOfItems;
            with List[j] do
            begin
              InterfaceInfo:= pInterfaceInfoList^.InterfaceInfo[0].strInterfaceDescription;
              Profile:= WideCharToString(pNetworkList^.Network[j].strProfileName);
              SSID:= PChar(@pNetworkList^.Network[j].dot11Ssid.ucSSID);
              Signal:= pNetworkList^.Network[j].wlanSignalQuality;
              Auth:= AuthStr[pNetworkList^.Network[j].dot11DefaultAuthAlgorithm];
              Conected:= (pNetworkList^.Network[j].dwFlags and WLAN_AVAILABLE_NETWORK_CONNECTED) <> 0;
            end;
          end;
          WlanFreeMemory(pNetworkList);
        end;
      end;
      WlanFreeMemory(pInterfaceInfoList);
    end;
    WlanCloseHandle(hClient, nil);
  end;
end;
 
function WifiConect(SSID: WideString): BOOL;
var
  hClient: THandle;
  dwVersion: DWORD;
  pInterfaceInfoList: PWLAN_INTERFACE_INFO_LIST;
  pInterfaceGuid: PGUID;
  i: integer;
  pWLCP: PWLAN_CONNECTION_PARAMETERS;
begin
  Result:= false;
  if ERROR_SUCCESS = WlanOpenHandle(1, nil, @dwVersion, @hClient) then
  begin
    if ERROR_SUCCESS = WlanEnumInterfaces(hClient, nil, @pInterfaceInfoList) then
    begin
      for i:= 0 to pInterfaceInfoList^.dwNumberOfItems - 1 do
      begin
        pInterfaceGuid:= @pInterfaceInfoList^.InterfaceInfo[pInterfaceInfoList^.dwIndex].InterfaceGuid;
        pWLCP:= WlanAllocateMemory(sizeof(TWLAN_CONNECTION_PARAMETERS));
        pWLCP.strProfile:= PWCHAR(SSID);
        pWLCP.wlanConnectionMode:= 0;
        pWLCP.pDot11Ssid:= nil; //pDot11_DDSI;
        pWLCP.pDesiredBssidList:= nil;
        pWLCP.dot11BssType:= 1;
        pWLCP.dwFlags:= 0;//$F;
        Result:= (ERROR_SUCCESS = WlanConnect(hClient, pInterfaceGuid, pWLCP, nil));
        WlanFreeMemory(pWLCP);
      end;
      WlanFreeMemory(pInterfaceInfoList);
    end;
    WlanCloseHandle(hClient, nil);
  end;
end;
 
function WifiDisConect: BOOL;
var
  hClient: THandle;
  dwVersion: DWORD;
  pInterfaceInfoList: PWLAN_INTERFACE_INFO_LIST;
  pInterfaceGuid: PGUID;
  i: integer;
begin
  Result:= false;
  if ERROR_SUCCESS = WlanOpenHandle(1, nil, @dwVersion, @hClient) then
  begin
    if ERROR_SUCCESS = WlanEnumInterfaces(hClient, nil, @pInterfaceInfoList) then
    begin
      for i:= 0 to pInterfaceInfoList^.dwNumberOfItems - 1 do
      begin
        pInterfaceGuid:= @pInterfaceInfoList^.InterfaceInfo[pInterfaceInfoList^.dwIndex].InterfaceGuid;
        WlanDisconnect(hClient, pInterfaceGuid, nil);
      end;
      WlanFreeMemory(pInterfaceInfoList);
    end;
    WlanCloseHandle(hClient, nil);
  end;
end;

Subo el código.

Saludos.

PD/ Existe una actualización aquí.

Archivos adjuntos

WiffiConnect.rar 163,19KB 54 descargas

#97602 Hook a la API CreateProcessInternalW en Win10

Escrito por escafandra el 19 diciembre 2016 - 08:20

Me plantearon una duda sobre el Hook a la API CreateProcessInternalW en Win10, la duda era porqué no funcionaba en Win10 si habían seguido el ejemplo que en su día publiqué aquí. Así que probé ha realizar un ejemplo y efectivamente no funcionaba. La API CreateProcessInternalW se exporta en Kernell32.dll y comprobé que así seguía siendo en win10.

Algo había cambiado en Win10 y como es una API indocumentada M$ no tiene porqué informar nada. Busqué en la red, pero no encontré nada, de esta forma tocaba usar el debugger y comparar direcciones de memoria de las API. El resultado es que Win10 usa la API exportada en KernelBase.dll y no la clásica Kernell32.dll. Una vez conocido este detalle el hook vuelve a funcionar.

Voy a poner un ejemplo hecho en delphi Berlin para resarcir la duda y aclarar la definición de esa API en delphi:

delphi

unit Unit1;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, APIHook, ShellAPI;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
// Defino esta estructura para los que quieran probar en delphi 7
PSTARTUPINFOW = ^_STARTUPINFOW;
_STARTUPINFOW = record
    cb: DWORD;
    lpReserved: PWideChar;
    lpDesktop: PWideChar;
    lpTitle: PWideChar;
    dwX: DWORD;
    dwY: DWORD;
    dwXSize: DWORD;
    dwYSize: DWORD;
    dwXCountChars: DWORD;
    dwYCountChars: DWORD;
    dwFillAttribute: DWORD;
    dwFlags: DWORD;
    wShowWindow: Word;
    cbReserved2: Word;
    lpReserved2: PByte;
    hStdInput: THandle;
    hStdOutput: THandle;
    hStdError: THandle;
  end;
 
PCreateProcessInternalW = function(hToken: THANDLE; pApplicationName, lpCommandLine: PWCHAR;
                                   lpProcessAttributes, lpThreadAttributes:    PSECURITYATTRIBUTES; bInheritHandles: BOOL;
                                   dwCreationFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: PWCHAR;
                                   lpStartupInfo: PSTARTUPINFOW; lpProcessInformation: PPROCESSINFORMATION; hNewToken: PHANDLE): BOOL; stdcall;
 
 
var
  OldCreateProcessInternalW: PCreateProcessInternalW = nil;
 
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
function NewCreateProcessInternalW(hToken: THANDLE; pApplicationName, lpCommandLine: PWCHAR;
                          lpProcessAttributes, lpThreadAttributes:    PSECURITYATTRIBUTES; bInheritHandles: BOOL;
                          dwCreationFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: PWCHAR;
                          lpStartupInfo: PSTARTUPINFOW; lpProcessInformation: PPROCESSINFORMATION; hNewToken: PHANDLE): BOOL; stdcall;
begin
  Result:= FALSE;
  Winapi.Windows.Beep(500, 100);
  exit;
//  Result:= OldCreateProcessInternalW(hToken, pApplicationName, lpCommandLine, lpProcessAttributes, lpThreadAttributes, bInheritHandles,
//                          dwCreationFlags, lpEnvironment, lpCurrentDirectory, lpStartupInfo, lpProcessInformation, hNewToken);
end;
//----------------------------------------------------------------------------
// Instalando los Hooks a las API
procedure InstallHooks;
begin
  InstallHook(@NewCreateProcessInternalW, @OldCreateProcessInternalW, 'Kernelbase.dll', 'CreateProcessInternalW', true);
end;
 
procedure UnInstallHooks;
begin
  UnInstallHook(@OldCreateProcessInternalW, 'KernelBase.dll', 'CreateProcessInternalW');
end;
 
procedure Execute(ProcessName: AnsiString);
var
  si: TStartupInfoA;
  pi: TProcessInformation;
 
begin
  ZeroMemory(@si, SizeOf(TStartupInfoA));
  si.cb := SizeOf(TStartupInfoA);
  si.dwFlags:= STARTF_USESHOWWINDOW;
  si.wShowWindow:= SW_SHOW;
 
  CreateProcessA(nil, PAnsiChar(ProcessName), nil, nil, false, 0, nil, nil, si, pi);
end;
 
 
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  InstallHooks;
  Execute('cmd.exe');
  ShellExecute(0,'open','cmd.exe', nil, nil, SW_SHOW);
  UnInstallHooks;
end;
 
end.
 
 
 
end.

El ejemplo muestra como un hook a la API CreateProcessInternalW es capaz de interceptar distintas formas de ejecutar un proceso.

El misterio queda resuelto.

Saludos.

Archivos adjuntos

CreateProcessInternalW.jpg 56,14KB 1 descargas
Hook_CreateProcessInternalW_Berlin.rar 53,78KB 28 descargas

#96794 [TRUCO DELPHI] Registrar y Desinstalar un ActiveX en Delphi.

Escrito por Rantor777 el 05 noviembre 2016 - 02:22

[TRUCO DELPHI] Registrar y Desinstalar un ActiveX en Delphi.

Declaración de Tipos.

delphi

type
  TDllRegisterServer = function: HResult; stdcall;

Función para registrar. [MÉTODO 1]

delphi

function RegisterOCX(FileName: string): Boolean;
var
  OCXHand: THandle;
  RegFunc: TDllRegisterServer;
begin
  OCXHand := LoadLibrary(PChar(FileName));
  RegFunc := GetProcAddress(OCXHand, 'DllRegisterServer');
  if @RegFunc <> nil then
    Result := RegFunc = S_OK
  else
    Result := False;
  FreeLibrary(OCXHand);
end;

Des Instalar o No Registrar.

delphi

function UnRegisterOCX(FileName: string): Boolean;
var
  OCXHand: THandle;
  RegFunc: TDllRegisterServer;
begin
  OCXHand := LoadLibrary(PChar(FileName));
  RegFunc := GetProcAddress(OCXHand, 'DllUnregisterServer');
  if @RegFunc <> nil then
    Result := RegFunc = S_OK
  else
    Result := False;
  FreeLibrary(OCXHand);
end;

Registrar [MÉTODO 2]

delphi

function RegisterServer(const aDllFileName: string; aRegister: Boolean): Boolean;
type
  TRegProc = function: HResult;
  stdcall;
const
  cRegFuncNameArr: array [Boolean] of PChar =
    ('DllUnregisterServer', 'DllRegisterServer');
var
  vLibHandle: THandle;
  vRegProc: TRegProc;
begin
  Result := False;
  vLibHandle := LoadLibrary(PChar(aDllFileName));
  if vLibHandle = 0 then Exit;
    @vRegProc := GetProcAddress(vLibHandle, cRegFuncNameArr[aRegister]);
  if @vRegProc <> nil then
    Result := vRegProc = S_OK;
  FreeLibrary(vLibHandle);
end;

Saludos! @Sir.Dev.A.Lot "Ya he comenzado."

#96620 Número de serie de una unidad de disco USB

Escrito por escafandra el 23 octubre 2016 - 12:19

Obtener el número de serie de una unidad USB es un tema buscado en las redes y muy mal documentado. En principio podríamos suponer que la tarea puede hacerse fácilmente con DeviceIoControl IOCTL_STORAGE_GET_MEDIA_SERIAL_NUMBER, pero la realidad es que falla para las unidades de disco USB. cHackAll escribió hace unos años un código que se basaba el leer el registro para encontrar esa información, pero en los actuales S.O. no funciona correctamente. Con motivo de una pregunta en CD, me acordé del antiguo código de cHackAll y me propuse revisar el tema. El código que propongo se basa en la lectura del registro y en verificar si la unidad está "pinchada" en nuestro PC.

El código está probado en WinXP y Win10.

En realidad es una información muy poco útil salvo para aquellos que quieran proteger sus creaciones con una mochila basada en un pendrive.

Este es el código:

delphi

var
 Device: ShortString;
 ValueName: array [0..15] of Char = '\DosDevices\\:';
 
 
const
 IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS  = $00560000;
 
// Encuentra el número de disco físico que corresponde a una letra de unidad
function GetPhysicalNumOfDrive(Volume: Char): integer;
var
  hFile: THandle;
  Vde: array [0..56] of BYTE;   // VOLUME_DISK_EXTENTS
  BytesReturned: Cardinal;
begin
  Result:= -1;
  hFile:= CreateFile(PAnsiChar('\\.\' + Volume + ':'),0,0,nil, OPEN_EXISTING, 0, 0);
  if hFile <> INVALID_HANDLE_VALUE then
  begin
    if DeviceIoControl(hFile, IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS, nil, 0, @Vde, SizeOf(Vde), BytesReturned, nil) then
      Result:= PBYTE(DWORD(@Vde)+8)^;
    CloseHandle(hFile);
  end;
end;
 
// Encuentra el número de serie de una letra de unidad para Win10
function GetUSBSerial10(Drive: Char; var SerialNumber: ShortString): LongBool;
var
  hKey: Windows.HKEY;
  Device: ShortString;
  ValueName: array [0..15] of Char;
  Index: Integer;
  Value: Char;
  Size: DWORD;
  i: integer;
  ValueType: DWORD;
begin
  ValueType:= 3;
  Size:= SizeOf(Device);
  Result := False;
  lstrcpy(ValueName, '\DosDevices\\:');
  ValueName[12] := Drive;
  RegOpenKey(HKEY_LOCAL_MACHINE, 'SYSTEM\MountedDevices', hKey);
  i:= RegQueryValueEx(hKey, @ValueName, nil, @ValueType{REG_BINARY}, @Device, @Size);
  RegCloseKey(hKey);
  if i = 0 then
  begin
    i:= SizeOf(Device);
    repeat  dec(i); until Device[i] = '&';  Device[i]:= #0;
    repeat  dec(i); until Device[i] = '#';
    Index := 1;
    repeat
      Value := Device[i + Index * 2];
      SerialNumber[Index]:= Value;
      inc(Index);
    until Value = #0;
    SerialNumber[0]:= CHAR(lstrlen(@SerialNumber[1]));
    Result:= SerialNumber[1] <> #0;
  end;
end;
 
// Modificado del código de cHackAll
function Search(hParent: HKEY; var SubKey: ShortString): LongBool;
var
 hChild: HKEY;
 Index: Cardinal;
 Data: ShortString;
 Size: DWORD;
 ValueType: DWORD;
begin
 ValueType:= 1; //REG_SZ
 Size:= SizeOf(Device);
 Index := 0;
 RegOpenKey(hParent, @SubKey[1], hChild);
 RegQueryValueEx(hChild, 'ParentIdPrefix', nil, @ValueType, @Data[0], @Size);
 Result := not LongBool(lstrcmp(@Data, @Device));
 while not Result and (RegEnumKey(hChild, Index, @SubKey[1], SizeOf(SubKey) - 1) = ERROR_SUCCESS) do
  begin
   Result := Search(hChild, SubKey);
   Inc(Index);
  end;
 RegCloseKey(hChild);
end;
 
// Modificado del código de cHackAll
function usbGetSerial(Drive: Char; var SerialNumber: ShortString): LongBool;
var
 lpSerialNumber: PChar;
 hKey: Windows.HKEY;
 Index: Integer;
 Value: Char;
 Size: DWORD;
 i: integer;
 ValueType: DWORD;
begin
 ValueType:= 3;
 Size:= SizeOf(Device);
 Result := False;
 ValueName[12] := Drive;
 i:= RegOpenKey(HKEY_LOCAL_MACHINE, 'SYSTEM\MountedDevices', hKey);
 RegQueryValueEx(hKey, @ValueName, nil, @ValueType{REG_BINARY}, @Device, @Size);
 RegCloseKey(hKey);
 
 Index := 0;
 repeat if Device[(Index + 3) * 2 + 54] <> '#' then
  Value := Device[Index * 2 + 54] else Value := #0;
  Device[Index] := Value;
  Inc(Index);
 until Value = #0;
 SerialNumber[0] := #0;
 lstrcpy(@SerialNumber[1], 'SYSTEM\CurrentControlSet\Enum\USBSTOR');
 if (Device[0] <> #0) and Search(HKEY_LOCAL_MACHINE, SerialNumber) then
  begin
   lpSerialNumber := @SerialNumber[1];
   repeat Inc(SerialNumber[0]);
    Inc(lpSerialNumber);
    if lpSerialNumber[0] = '&' then
     lpSerialNumber[0] := #0;
   until lpSerialNumber[0] = #0;
   Result := True;
  end;
end;
 
function GetSOVersion: integer;
var
  VerInfo: TOSVersioninfo;
begin
  VerInfo.dwOSVersionInfoSize:= SizeOf(TOSVersionInfo);
  GetVersionEx(VerInfo);
  Result:= VerInfo.dwMajorVersion; // 5 es XP, mayor vista...
end;
 
function GetUSBSerial(Drive: Char; var SerialNumber: ShortString): LongBool;
begin
  if(GetSOVersion > 5) then
    Result:= GetUSBSerial10(Drive, SerialNumber)
  else
    Result:= usbGetSerial(Drive, SerialNumber);
end;

Y un ejemplo de uso:

delphi

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
  SerialNumber: ShortString;
begin
  Edit1.Text:='';
  Label1.Caption:= '';
  if GetPhysicalNumOfDrive(Key) <> -1 then
  begin
    GetUSBSerial(Key, SerialNumber);
    Label1.Caption:= SerialNumber;
  end
  else MessageBox(Handle, 'Unmounted drive', 'Error', MB_ICONEXCLAMATION);
end;

Subo un proyecto completo con el ejemplo.

Saludos.

Archivos adjuntos

GetUSBSerial.rar 161,08KB 50 descargas

#92511 Compartiendo codigo...

Escrito por Agustin Ortu el 21 diciembre 2015 - 10:45

Hola,

Me he creado un repositorio en GitHub en el que ire metiendo clases, funciones, procedimientos, ejemplos y esa clase de yerbas

Ojala pueda mantenerlo actualizado

Gusten tomar lo que quieran

Saludos

#91914 Richmemo para word

Escrito por El_Chava el 29 octubre 2015 - 03:42

Bueno al fin dí con una solución no se si será la más adecuada pero hace lo que necesito. Para esto se uso un marcador en donde se insertara lo contenido en el richMemo. Al final lo que utilice es que lo que contenga en el richmemo lo coopio al portapapeles y al final realizo un pegado especial en el documento word. Aquí les dejo el código.

delphi

var
  Word,marcador,doc1: Variant;
  w:widestring;
 try
    {* a la variable "w" le asigno la ruta donde se encuentra la plantilla a utilizar *}
    w:= UTF8Decode(ExtractFilePath(application.ExeName)+'plantillas\Respuesta01.rtf');
    Word := CreateOleObject('Word.Application');
    (* Añades un documento basado en la plantilla *)
  Documento := Word.Documents.Add(w);
  Documento := Word.Documents.Item(1);
  doc1:= Word.ActiveDocument;
  RichMemo1.SelectAll; {Se selecciona todo el texto que contenga el Rich memo}
  RichMemo1.CopyToClipboard {Se copia lo seleccionado al portapapeles};
  Richmemo1.SelLength:=0 {se quita la selección};   
 if Doc1.Bookmarks.Exists('prueba') then   {Chequea si existen las marcas en el documento}
  Begin
       Doc1.Bookmarks.Item('prueba').Range.PasteSpecial;
{Se realiza el pegado especial del portapapeles en el marcador creado
 en el documento de word}
 end;     
 
Word.Visible := true;  {Make Word visible}
Clipboard.Clear;{se limpia el portapales}
  except
   on E: Exception do
      ShowMessage(SysToUTF8(E.Message));
  end;

Para limpiar el portapaples es necesario que usar el unit Clipbrd. Espero y les sirva este metodo. Saludos. ^\||/

#91177 [MULTILENGUAJE] Como colocar las flechitas que indican el orden de columnas d...

Escrito por escafandra el 16 septiembre 2015 - 04:32

Windows tiene previsto un sistema con unos iconos que indican el orden en las columnas de un ListView, ascendente o descendente. No conozco si las últimas versiones de delphi lo incluyen, hasta la versión 7 no es así, de modo que me puse a trabajar en este truco, a raiz de una pregunta similar en un foro dedicado a Builder en el que suelo participar.

Esta sería la versión para delphi:

delphi

procedure SetSortIcon(List: TListView; ColumnIndex: integer; Ascending: integer);
const
  HDF_SORTDOWN = $0200;
  HDF_SORTUP   = $0400;
var
  hHeader: THANDLE;
  HD: HD_ITEM;
begin
  hHeader := SendMessage(List.Handle, LVM_GETHEADER, 0, 0);
  HD.mask:= HDI_FORMAT;
  SendMessage(hHeader, HDM_GETITEM, ColumnIndex, Integer(@HD));
  if Ascending = 0 then
    HD.fmt:= (HD.fmt and not HDF_SORTUP) or HDF_SORTDOWN
  else
    HD.fmt:= (HD.fmt and not HDF_SORTDOWN) or HDF_SORTUP;
   SendMessage(hHeader, HDM_SETITEM, ColumnIndex, Integer(@HD));
end;

La forma de uso:

delphi

procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);
var
  i: integer;
begin
  Column.Tag:= Column.Tag xor 1; // 0 descendente y 1 ascendente
  SetSortIcon(ListView1, Column.Index, Column.Tag);
 
  // Aquí se implementaría la llamada a la función de ordenación de la columna
  TListView(Sender).CustomSort(@SortByColumn, Column.Index);
end;

Se debe incluir le archivo de recursos para WinXP para que funcione.

Saludos.

#90861 Enviar una impresión a una impresora de Red

Escrito por escafandra el 14 agosto 2015 - 06:53

Esta función resuelve la IP encontrando el nombre de la impresora, a partir de ahí puedes usar ese nombre para imprimir.

delphi

uses
  Windows, SysUtils, Winsock, Winspool;
 
type
  APrinterInfo2 = array [0..0] of TPrinterInfo2;
  PAPrinterInfo2 = ^APrinterInfo2;
 
function GetPrinterName(IP: String): String;
var
  Data: TWSADATA;
  He: Phostent;
  Addr: integer;
  List: PAPrinterInfo2; //PPrinterInfo2;
  SizeNeeded, NumItems, Item: DWORD;
begin
  Result:= '';
  if WSAStartup(MAKEWORD(1, 1), Data) = 0 then
  begin
    Addr:= inet_addr(PCHAR(IP));
    if Addr <> INADDR_NONE then
    begin
      He:= gethostbyaddr(@Addr, sizeof(Addr), AF_INET);
      if He <> nil then
        Result:= He.h_name;
    end;
    WSACleanup;
  end;
  if Result <> '' then
  begin
    if pos('.', Result) > 0 then
      Result:= copy(Result, 1, pos('.', Result)-1);
    EnumPrinters(PRINTER_ENUM_LOCAL, nil, 2, nil, 0, SizeNeeded, NumItems);
    GetMem(List, SizeNeeded);
    if EnumPrinters(PRINTER_ENUM_LOCAL, nil, 2, List, SizeNeeded, SizeNeeded, NumItems) then
    begin
      for Item:= 0 to NumItems-1 do
      begin
        if List[Item].pPortName = Result then
        begin
          Result:= List[Item].pPrinterName;
          break;
        end;
      end;
    end;
    FreeMem(List);
  end;
end;

Saludos.

#90453 imágenes para botones

Escrito por cram el 08 julio 2015 - 09:58

Les dejo algunas imágenes que creé para usar como glyphs para botones con bitmap (TBitmapButtons) o simplemente para acompañar algún control que las necesite.

Están en bmp 24x24 y png 40x40 transparentes y sólidas

botones.jpg 45,72KB 20 descargas

Espero les sirva.

Saludos

Archivos adjuntos

Botones.7z 13,22KB 66 descargas

#90200 Cotilleando un ListView de otro proceso...

Escrito por escafandra el 25 junio 2015 - 06:33

Leyendo detenidamente la pregunta de look vi un detalle que pretendía que no está contamplado en WinInfo. Se trata de poder leer el contenido de un ListView.

Para esa tarea, Windows tiene previsto el acceso a través de mensajes encapsulados en macros estilo C: List View, la pega es que no funcionan si se trata de acceder desde un proceso distinto, se debe a la compartimentación de la memoria aislada entre procesos. Pudiera parecer que es un escollo insalvable, pero no lo es si "invadimos" el proceso a espiar, para eso están las APIs VirtualAllocEx, WriteProcessMemory y ReadProcessMemory.

Armados con estas APIs y obteniendo el Handle del proceso anfitrión podemos invadir su memoria y extraer los datos que buscamos.

Lo que sigue es un ejemplo que fisgonea en un ListView de un proceso ajeno coniciendo previamente el Handle de ventana de dicho control y las coordenadas del "mouse" donde se encuentra el Item a asaltar, obtenemos los subitems. El sumitem[0] representa el texto principal del Item mientras que números superiores representan los siguientes subitems en orden.

El código está diseñado para encajarlo en WinInfo, que ya se encarga de obtener el Handle y las coordenadas necesarias pero se puede adaptar para uso en otros entronos.

delphi

function  GetLVText(hListView: HWND; X, Y: integer; iSubItem: Cardinal): String;
var
  pid: DWORD;
  hProcess: THANDLE;
  IInfo: TLVHITTESTINFO;
  _IInfo: PLVHITTESTINFO;
  Index: integer;
  Buffer: array [0..511] of CHAR;
  _Buffer: PCHAR;
  Item: TLVITEM;
  _Item: PLVITEM;
begin
  Result:= '';
  GetWindowThreadProcessId(hListView, pid);
  hProcess:= OpenProcess(PROCESS_VM_OPERATION or PROCESS_VM_READ or
                     PROCESS_VM_WRITE or PROCESS_QUERY_INFORMATION, FALSE, pid);
  if hProcess <> THANDLE(0)  then
  begin
    // Encontramos el índice del LVItem en X, Y
    Index:= -1;
    IInfo.pt:= Point(10, Y);
    _IInfo:= VirtualAllocEx(hProcess, nil, sizeof(TLVHITTESTINFO), MEM_COMMIT, PAGE_READWRITE);
    WriteProcessMemory(hProcess, _IInfo, @IInfo, sizeof(TLVHITTESTINFO), PDWORD(0)^);
    Index:= ListView_HitTest(hListView, _IInfo^);
    if Index >= 0 then
    begin
      // Encontramos el Texto del Item
      _Buffer:= VirtualAllocEx(hProcess, nil, sizeof(Buffer), MEM_COMMIT, PAGE_READWRITE);
      _Item:=   VirtualAllocEx(hProcess, nil, sizeof(TLVITEM), MEM_COMMIT, PAGE_READWRITE);
 
      Item.iSubItem:= iSubItem;
      Item.pszText:= _Buffer;
      Item.cchTextMax:= sizeof(Buffer);
 
      WriteProcessMemory(hProcess, _Item, @Item, sizeof(TLVITEM), PDWORD(0)^);
      SendMessage(hListView, LVM_GETITEMTEXT, Index, Cardinal(_Item));
      ReadProcessMemory(hProcess, _Buffer, @Buffer[0], sizeof(Buffer), PDWORD(0)^);
      Result:= String(Buffer);
      // Liberamos memoria del proceso
      VirtualFreeEx(hProcess, _Item, 0, MEM_RELEASE);
      VirtualFreeEx(hProcess, _Buffer, 0, MEM_RELEASE);
    end;
    // Liberamos memoria del proceso
    VirtualFreeEx(hProcess, _IInfo, 0, MEM_RELEASE);
  end;
end;

Saludos.

#101001 Eliminar la opción "Ejecutar como Administrador" del menú del botón d...

Escrito por escafandra el 13 abril 2018 - 04:27

Seguro que alguien ha tenido la necesidad de desactivar la opción de "Ejecutar como Administrador" del menú del botón derecho del ratón. Sin ir muy lejos me lo preguntaron recientemente. Una opción para realizar esto es el registro de Windows. Las eliminación de siguientes claves consigue el efecto deseado:

delphi

HKEY_CLASSES_ROOT\batfile\shell\runas
HKEY_CLASSES_ROOT\cmdfile\shell\runas
HKEY_CLASSES_ROOT\cpfile\shell\runas
HKEY_CLASSES_ROOT\exefile\shell\runas
HKEY_CLASSES_ROOT\mscfile\shell\runas

Pero eliminar sin un backup nunca es bueno hablando del registro por lo que guardaremos una copia de las mismas con ayuda del código que publiqué recientemente aquí : RegCopyKey

El siguiente código realiza la rarea para claves individuales:

delphi

function RegHideRunAs(SubKey: String): integer;
var
  SrcKey, TrgKey: HKEY;
begin
  Result:= RegOpenKeyExA(HKEY_CLASSES_ROOT, PAnsiChar(SubKey + '\shell\runas') , 0, KEY_READ, SrcKey);
  if Result = ERROR_SUCCESS then
  begin
    Result:= RegOpenKeyExA(HKEY_CLASSES_ROOT, PAnsiChar(SubKey), 0, KEY_READ, TrgKey);
    if Result = ERROR_SUCCESS then
    begin
      Result:= RegCopyKey(SrcKey, TrgKey, 'BkRunAs');
      RegCloseKey(SrcKey);
    end;
    RegCloseKey(TrgKey);
  end;
  if Result = ERROR_SUCCESS then
    RegDeleteTreeA(HKEY_CLASSES_ROOT, PAnsiChar(SubKey + '\shell\runas'));
end;
 
function RegRestoreRunAs(SubKey: String): integer;
var
  SrcKey, TrgKey: HKEY;
begin
  Result:= RegOpenKeyExA(HKEY_CLASSES_ROOT, PAnsiChar(SubKey + '\BkRunAs'), 0, KEY_READ, SrcKey);
  if Result = ERROR_SUCCESS then
  begin
    Result:= RegOpenKeyExA(HKEY_CLASSES_ROOT, PAnsiChar(SubKey + '\shell'), 0, KEY_READ, TrgKey);
    if Result = ERROR_SUCCESS then
    begin
      Result:= RegCopyKey(SrcKey, TrgKey, 'runas');
      RegCloseKey(SrcKey);
    end;
    RegCloseKey(TrgKey);
  end;
  if Result = ERROR_SUCCESS then
    RegDeleteTreeA(HKEY_CLASSES_ROOT, PAnsiChar(SubKey + '\BkRunAs'));
end;

Y la siguiente función realiza la tarea conjunta:

delphi

function ShowRunAs(Visible: boolean): integer;
begin
{
HKEY_CLASSES_ROOT\batfile\shell\runas
HKEY_CLASSES_ROOT\cmdfile\shell\runas
HKEY_CLASSES_ROOT\cpfile\shell\runas
HKEY_CLASSES_ROOT\exefile\shell\runas
HKEY_CLASSES_ROOT\mscfile\shell\runas
}
  if Visible then
  begin
    RegRestoreRunAs('batfile');
    RegRestoreRunAs('cmdfile');
    RegRestoreRunAs('cpfile');
    RegRestoreRunAs('exefile');
    RegRestoreRunAs('mscfile');
  end
  else
  begin
    RegHideRunAs('batfile');
    RegHideRunAs('cmdfile');
    RegHideRunAs('cpfile');
    RegHideRunAs('exefile');
    RegHideRunAs('mscfile');
  end;
end;

Pues ya tenemos la herramienta para esconder y restaurar la opción "Ejecutar como Administrador" del menú del botón derecho del ratón.

Saludos.

PD/ Edito para unificar en AnsiChar

#99903 [TUTORIAL] Arduino C++ y Puerto serie

Escrito por Meta el 14 julio 2017 - 10:33

Tutorial Arduino C++ y Puerto serie. Puedes hacer controlar Arduino y el puerto serie desde el lenguaje C++ Win32. Hay tres IDE para elegir para crear tu propio programa en C++ como Visual Studio 2017, Code::Blocks y C++ Builder Starter.

Antes que nada saber que puerto usamos:
// Para crear conexión con los puertos COM1 - COM9.
// Serial* Arduino = new Serial("COM7");

// Para crear conexión con los puertos COM10 en adelante.
// Serial* Arduino = new Serial("\\\\.\\COM10");

Abrir conexión del puerto:
Puerto->IsConnected()

Enviar información a Arduino:
// Encener luz.
cout << "Enviando: " << Luz_ON << endl; // Muestra en pantalla textos.
Puerto->WriteData(Luz_ON, sizeof(Luz_ON) - 1); // Envía al puerto el texto "Luz_ON".

Código de Arduino:

php

// Encendido y apagado del Led 13 mediante puerto serie.
 
const byte Led = 13;   // Declaramos la variable pin del Led.
char caracter;
String comando;
 
void setup()
{
  pinMode(Led, OUTPUT);  // Inicializa el pin del LED como salida:
  Serial.begin(115200);     // Puerto serie 115200 baudios.
}
 
void loop()
{
  /*
    Voy leyendo carácter a carácter lo que se recibe por el canal serie
    (mientras llegue algún dato allí), y los voy concatenando uno tras otro
    en una cadena. En la práctica, si usamos el "Serial monitor" el bucle while
    acabará cuando pulsamos Enter. El delay es conveniente para no saturar el
    canal serie y que la concatenación se haga de forma ordenada.
  */
  while (Serial.available() > 0)
  {
    caracter = Serial.read();
    comando.concat(caracter);
    delay(10);
  }
 
  /*
    Una vez ya tengo la cadena "acabada", compruebo su valor y hago que
    la placa Arduino reacciones según sea este. Aquí podríamos hacer lo
    que quisiéramos: si el comando es "tal", enciende un Led, si es cual,
    mueve un motor... y así.
  */
 
  // Si le llega el mensaje Luz_ON.
  if (comando.equals("Luz_ON") == true)
  {
    digitalWrite(Led, HIGH); // Enciende el Led 13.
    Serial.write("ON - Led encendido.");    // Envía este mensaje a C++.
  }
 
  // Si le llega el mensaje Luz_ON.
  if (comando.equals("Luz_OFF") == true)
  {
    digitalWrite(Led, LOW); // Apaga el Led 13.
    Serial.write("OFF - Led apagado. ");  // Envía este mensaje a C++.
  }
 
  // Limpiamos la cadena para volver a recibir el siguiente comando.
  comando = "";
}

Código C++:

php

#include
#include
#include
#include "SerialClass.h"
using namespace std;
 
void main()
{
    // Título de la ventana
    SetConsoleTitle("Control Led Arduino - Visual Studio C++ 2017");
 
    // Puerto serie.
    Serial* Puerto = new Serial("COM4");
 
    // Comandos para Arduino.
    char Luz_ON[] = "Luz_ON"; // Envía "Luz_ON" al puerto serie.
    char Luz_OFF[] = "Luz_OFF";
    char lectura[50] = "\0"; // Guardan datos de entrada del puerto.
 
    int opc; // Guarda un 1 o 2 tipo entero queintroduces desde la consola.
 
    while (Puerto->IsConnected())
    {
        cout << endl; // Retorno.
        cout << "Introduzca la opcion deseada: " << endl;
        cout << "Pulse 1 para encender el Led, pulse 2 para apagar." << endl << endl; // Muestra texto en pantalla.
 
        cin >> opc; // Aquí introduces un número, el 1 o el 2.
 
        switch (opc) // Espera recibir un 1 o un 2.
        {
        case 1:
            // Encener luz.
            cout << "Enviando: " << Luz_ON << endl; // Muestra en pantalla textos.
            Puerto->WriteData(Luz_ON, sizeof(Luz_ON) - 1); // Envía al puerto el texto "Luz_ON".
            break;
 
        case 2:
            // Apagar luz.
            cout << "Enviando: " << Luz_OFF << endl;
            Puerto->WriteData(Luz_OFF, sizeof(Luz_OFF) - 1);
            break;
 
        default: // Si haz pulsado otro número distinto del 1 y 2, muestra
            cout << "Puse del 1 al 2."; // este mensaje.
        }
 
 
        Sleep(500);
        int n = Puerto->ReadData(lectura, 49); // Recibe datos del puerto serie.
        if (n > 0)
        {
            lectura[n + 1] = '\0'; // Limpia de basura la variable.
            cout << "Recibido: " << lectura << endl; // Muestra en pantalla dato recibido.
            cout << "-------------------" << endl;
        }
 
        cin.ignore(256, '\n'); // Limpiar buffer del teclado.
    }
}

Ver Visor.

Ver vídeo.

Ver PDF.

Un cordial saludo.

#99648 Acceso a Base de Datos con Delphi Starter

Escrito por egostar el 02 junio 2017 - 08:26

Pues eso,

He publicado un artículo donde muestro conmo acceder a una base de datos desde Delphi Starter el cual no cuenta con ésta facilidad pero que al permitir la instalación de componentes de terceros es posible hacerlo.

En éste tutorial utilizo los componentes Zeos para acceder a una base de datos SQLite.

La idea de hacer este tipo de tutoriales es un intento de acercar a las nuevas generaciones a aprender y utilizar Delphi, ciertamente la Edición Starter viene muy limitada pero para iniciar el aprendizaje de Delphi y para desarrollar aplicaciones para Windows me parece una buena alternativa.

Ojala y sea de utilidad.

Acceso a base de datos SQLite desde Delphi Starter

Saludos

#99616 Curso introductorio a Lazarus y Delphi en UDEMY

Escrito por axesys el 28 mayo 2017 - 01:20

Hola a todos, les comparto un cupón del 100% de descuento para mi primer curso de Delphi en UDEMY, espero que sea de su agrado.

https://www.udemy.co...uponCode=DELPHI

Saludos

#99379 Delphi Novedades Abril 2017

Escrito por poliburro el 28 abril 2017 - 08:30

Tomado de: https://goo.gl/N9fbaU

Delphi continúa en el Top Ten.

El mes de marzo Embarcadero publicó una nota mencionando que Delphi se encontraba dentro del Top ten de lenguajes más populares. En abril, la tendencia continua manteniendo a Delphi/Object Pascal en la posición 9 del índice.

Alianza de Embarcadero con Mitov Software.

Embarcadero anunció su alianza con Mitov Software para integrar su suite de componentes de terceros la librería de AI IntelligenceLab que permite a los desarrolladores desarrollar aplicaciones para filtrar spam, de visión por computadora, reconocimiento de voz o cualquier otra tarea relacionada con IA. Saber más.

Finalizada la competencia para elegir el logo de la camiseta oficial de Tokio.

Tras una muy reñida competencia, la competencia para seleccionar el logo de la camisa oficial para Tokio ha finalizado. Los tres han sido:

Delphi Tokio Starter.

Ya se puede descargar la versión gratuita de Delphi que permite a los desarrolladores crear aplicaciones en windows. Enlace de Descarga.

Proyecto PicPas Actualizado. El creador de este compilador de pascal para microcontroladores de gama media ha anunciado una nueva versión. Ver.

Speech Recognizer. Nos comparten el código fuente de un proyecto de reconocimiento de voz con Delphi en Android. Ver.

Editor multiplataforma. Nos comparten información del proyecto open source Trolledge desarrollado con Delphi. Ver.

fpcupdeluxe es una herramienta con interfaz gráfica que se encarga de administrar instalaciones de FreePascal y Lazarus. Ver

Serialización JSON en Tokyo.

Artículo escrito por Agustín Ortu sobre las unidades System.JSON.Serializers y System.JSON.Converters que sirven para trabajar con JSON, en particular, convertir objetos Delphi a JSON, y también el proceso inverso, crear un objeto Delphi a partir de una estructura JSON. Ver.

Consumir un servicio web con Delphi 10.2 Starter y cURL.

Artículo escrito por Eliseo González que nos muestra de qué manera consumir un servicio web de Banxico para determinar el tipo de cambio de una moneda. Ver.

El plugin TestInsight.

En este artículo Agustín nos habla sobre el plugin TestInsight que se trata de un pequeño experto que se integra en el IDE y permite correr los test de unidad y ver los resultados, directamente desde el IDE, y no ejecutándolos en un programa externo. Ver.

Un nuevo compilador para microcontroladores.

Tito Hinostroza describe en su blog los argumentos que lo llevaron a crear un compilador de lenguaje pascal para microcontroladores así como sus ventajas. Ver.

#97054 Encriptando funciones

Escrito por escafandra el 19 noviembre 2016 - 08:39

Voy a tratar de explicar como proteger una app encriptando una función vital para el programa. La clave de descifrado dependerá de la clave de la licencia.

Imaginemos un código como este en el que una función es vital porque importa dinámicamente un procedimiento esencial de una dll:

delphi

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
 
type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
type PLogueado = procedure; stdcall;
 
implementation
 
{$R *.dfm}
var
Logueado: PLogueado;
 
 
procedure Vital;
var
  hLib: HMODULE;
begin
  hLib:= LoadLibrary('UnaDll.dll');
  Logueado:= GetProcAddress(hLib, 'Logueado');
  if @Logueado <> nil then
    Logueado;
end;}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  Vital;
end;
 
end.

Para el ejemplo, esta será la dll:

delphi

library UnaDll;
 
uses
  Windows;
 
{$R *.res}
 
 
procedure Logueado;
begin
 MessageBox(0, 'El programa funcionará correctamente', 'Eureca', MB_OK);
end;
 
exports
Logueado;
 
begin
end.

Ahora vamos a cambiar las cosas para encriptar el procedimiento Vital. Añadimos una función o procedimiento de cifrado, otro de descifrado y otro para guardar el binario cifrado de Vital. El procedimiento FinVital hay que dejarlo justo al final de Vital:

delphi

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
 
type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
type PLogueado = procedure; stdcall;
 
implementation
 
{$R *.dfm}
var
Logueado: PLogueado;
 
// Una función de cifrado simétrico...
procedure Crypt(Source: Pointer; Size: Cardinal; Password: PCHAR; _Mod: integer);
var
  S: PCHAR;
  len, n: integer;
begin
   S:= Source;
   len:= lstrlen(Password);
   for n:=0 to Size-1 do
   begin
     S[n]:= CHAR(integer(S[n]) xor integer(Password[_Mod mod len]));
     inc(_Mod);
   end;
end;
 
procedure Vital;
var
  hLib: HMODULE;
begin
  hLib:= LoadLibrary('UnaDll.dll');
  Logueado:= GetProcAddress(hLib, 'Logueado');
  if @Logueado <> nil then
    Logueado;
end;}
// Este procedimiento inservible nos ayudará a encontrar el tamaño asm de Vital
procedure FinVital; begin end;
 
// Este procedimiento copia Vital en un buffer, lo encripta y lo guarda en un archivo binario.
procedure ExtraeVital;
var
  hFile: THANDLE;
  Size: integer;
  Buffer: PBYTE;
begin
  hFile:= CreateFile('Vital.bin', GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_FLAG_WRITE_THROUGH, 0);
  if hFile <> INVALID_HANDLE_VALUE then
  begin
    //Calculamos el tamaño de Vital
    Size:= UINT(@FinVital) - UINT(@Vital);
    Buffer:= GetMemory(Size);
    CopyMemory(Buffer, @Vital, Size);
    Crypt(Buffer, Size, 'escafandra', 0);
    _lwrite(hFile, PAnsiChar(Buffer), Size);
    CloseHandle(hFile);
    FreeMemory(Buffer);
  end;
end;
 
// Descifra Vital en su propia localización
procedure DescifraVital;
var
  Size: integer;
  OldProtect: DWORD;
begin
  //Calculamos el tamaño de Vital
  Size:= UINT(@FinVital) - UINT(@Vital);
  VirtualProtectEx(DWORD(-1), @Vital, Size, PAGE_EXECUTE_READWRITE, @OldProtect);
  Crypt(@Vital, Size, PCHAR(Form1.Edit1.Text), 0);
  VirtualProtectEx(DWORD(-1), @Vital, Size, OldProtect, nil);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  ExtraeVital;
  DescifraVital;
  Vital;
end;
 
end.

Ahora, con ayuda de alguna app que nos pase un binario a texto (FileToCode) hardcodeamos Vital con el resultado obtenido:

delphi

unit Vital_;
 
interface
 
uses Windows;
 
var
Vital_Size: integer = 80;
 
Vital_Bytes: array [0..79] of BYTE = 
(
  $30, $F8, $8F, $30, $0E, $65, $9F, $20, $72, $89, $2B, $1D, $98, $9E, $EF, $24, 
  $92, $0C, $62, $90, $21, $73, $E8, $24, $9A, $31, $86, $C1, $1F, $9A, $9A, $D0, 
  $BB, $4A, $23, $61, $ED, $59, $AA, $4A, $20, $73, $63, $15, $60, $9E, $7B, $BC, 
  $59, $24, $65, $2A, $3E, $A2, $66, $61, $3B, $0A, $13, $25, $09, $1F, $4D, $05, 
  $0A, $0D, $6E, $64, $3E, $0E, $02, $06, $06, $00, $02, $0E, $6E, $64, $72, $61
);
implementation
end.

El procedimiento VItal quedará como sigue:

delphi

procedure Vital;
asm
db  $30, $F8, $8F, $30, $0E, $65, $9F, $20, $72, $89, $2B, $1D, $98, $9E, $EF, $24;
db  $92, $0C, $62, $90, $21, $73, $E8, $24, $9A, $31, $86, $C1, $1F, $9A, $9A, $D0;
db  $BB, $4A, $23, $61, $ED, $59, $AA, $4A, $20, $73, $63, $15, $60, $9E, $7B, $BC;
db  $59, $24, $65, $2A, $3E, $A2, $66, $61, $3B, $0A, $13, $25, $09, $1F, $4D, $05;
db  $0A, $0D, $6E, $64, $3E, $0E, $02, $06, $06, $00, $02, $0E, $6E, $64, $72, $61;
end;

Solo quede hacer tres cosas, sustituir el el código fuente Vital por su nueva implementación "justo en su mismo lugar", trucar ExtraeVital para que no guarde archivos y cambiar la cadena de cifrado por otra cosa de un carácter, ¡no debemos dejarla expuesta!. Este paso es crucial, no debemos alterar mucho el código porque hay que recordar los saltos relativos asm. Cuando recompilemos al gún salto o llamada call puede cambiar su dirección relativa, por lo tanto el código final no puede alterarse mucho.Hay que tener cuidado de dejar todos los procedimientos donde están:

Este es el resultado final:

delphi

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
 
type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
type PLogueado = procedure; stdcall;
 
implementation
 
{$R *.dfm}
var
Logueado: PLogueado;
 
procedure Crypt(Source: Pointer; Size: Cardinal; Password: PCHAR; _Mod: integer);
var
  S: PCHAR;
  len, n: integer;
begin
   S:= Source;
   len:= lstrlen(Password);
   for n:=0 to Size-1 do
   begin
     S[n]:= CHAR(integer(S[n]) xor integer(Password[_Mod mod len]));
     inc(_Mod);
   end;
end;
 
 
procedure Vital;
asm
db  $30, $F8, $8F, $30, $0E, $65, $9F, $20, $72, $89, $2B, $1D, $98, $9E, $EF, $24;
db  $92, $0C, $62, $90, $21, $73, $E8, $24, $9A, $31, $86, $C1, $1F, $9A, $9A, $D0;
db  $BB, $4A, $23, $61, $ED, $59, $AA, $4A, $20, $73, $63, $15, $60, $9E, $7B, $BC;
db  $59, $24, $65, $2A, $3E, $A2, $66, $61, $3B, $0A, $13, $25, $09, $1F, $4D, $05;
db  $0A, $0D, $6E, $64, $3E, $0E, $02, $06, $06, $00, $02, $0E, $6E, $64, $72, $61;
end;
{
procedure Vital;
var
  hLib: HMODULE;
begin
  hLib:= LoadLibrary('UnaDll.dll');
  Logueado:= GetProcAddress(hLib, 'Logueado');
  if @Logueado <> nil then
    Logueado;
end;
}
procedure FinVital; begin end;
 
procedure ExtraeVital;
var
  hFile: THANDLE;
  Size: integer;
  Buffer: PBYTE;
begin
  hFile:= 0;  // Un Handle de archivo nulo evita que se ejecute este procedimiento
  CreateFile('Vital.bin', GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_FLAG_WRITE_THROUGH, 0);
  if hFile <> INVALID_HANDLE_VALUE then
  begin
    //Calculamos el tamaño de Vital
    Size:= UINT(@FinVital) - UINT(@Vital);
    Buffer:= GetMemory(Size);
    CopyMemory(Buffer, @Vital, Size);
    Crypt(Buffer, Size, '?', 0);
    _lwrite(hFile, PAnsiChar(Buffer), Size);
    CloseHandle(hFile);
    FreeMemory(Buffer);
  end;
end;
 
procedure DescifraVital;
var
  Size: integer;
  OldProtect: DWORD;
begin
  //Calculamos el tamaño de Vital
  Size:= UINT(@FinVital) - UINT(@Vital);
  VirtualProtectEx(DWORD(-1), @Vital, Size, PAGE_EXECUTE_READWRITE, @OldProtect);
  Crypt(@Vital, Size, PCHAR(Form1.Edit1.Text), 0);
  VirtualProtectEx(DWORD(-1), @Vital, Size, OldProtect, nil);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  ExtraeVital;
  DescifraVital;
  Vital;
end;
 
end.

No hay condicionales, sólo una dependencia. Si Vital no es desencriptada correctamente la app dará una excepción o se colgará. Vital no se ejecutará alterando definitivamente el programa.

Para implementarlo en una app, habra que hacerlo en la versión liberada y probar que funciona.

Recordar que si falla es que no hemos tenido cuidado con los JMP y CALL relativos.

La fortaleza de la protección la dará el sistema de cifrado ejegido, yo he usado para el ejemplo un método simétrico XOR, no es el más apropiado pero para el ejemplo sirve.

Ahora os reto a cojer el ejecutable y crakearlo para que funcione la función Vital. No valen las trampas, sólo se puede usar el ejecutable. :dlaug: *-)
Espero que os sirva u os de nuevas ideas para vuestras protecciones.

Subo el ejemplo que he escrito.

Saludos.

Archivos adjuntos

Antickrack.rar 198,68KB 16 descargas

#96800 TPelota

Escrito por escafandra el 06 noviembre 2016 - 02:55

Os presento una clase pelota que simula el comportamiento real de una pelota confinada en una ventana rebotando por sus paredes. Simula el movimiento uniformemente acelerado y el giro de la pelota, que se ve afectado por los choques. Se puede incluir un coeficiente de rozamiento, en cuyo caso, la pelota termina cayendo y rodando por el suelo hasta detenerse.

En principio usa como imagen un balón de fútbol, pero puede usarse otra como muestra el ejemplo adjunto.

El código lo escribí el año pasado como diversión y para mostrar a mi hijo el movimiento uniformemente acelerado, y como simularlo jugando con las leyes físicas. Aunque se puede mejorar, para mis propósitos salió bastante redondo.

Finalmente se me ocurrió escribir una broma en la que el escritorio se va llenando de pelotas que se multiplican cuando una cae y se para.

Os muestro el código de la clase:

delphi

unit Pelota;
 
interface
 
uses
  Windows, Messages;
 
type
TBox = (
  ParedIzquierda,
  Techo,
  ParedDerecha,
  Suelo
);
 
UINT_PTR = DWORD; // Para 64bits
 
function  sWinProc(Wnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD; stdcall;
procedure sTimerProc(Wnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
 
type
TPelota = class;
 
TWallEvent    = procedure(Pelota: TPelota; Pared: TBox; var Rebote: BOOL) of object;
TMissingEvent = procedure(Pelota: TPelota; Pared: TBox) of object;
TStopEvent    = procedure(Pelota: TPelota) of object;
 
TPelota = class
private
  gdiplusToken: DWORD;
  Left, Top, Width, Height: integer;
  Rebote: BOOL;
  AutoTimer: BOOL;
  CR: double;     // Cte de rotación : 360/(PI*Diámetro);
  FR: double;     // Factor de rotación en bote
  Ao: double;     // Angulo de rotación inicial;
  Bitmap, BitmapBak:   HBITMAP;     // Bitmap de la pelota
  BitmapDC, BitmapDCBak: HDC;       // HDC de los Bitmaps
  function  CreateBitmap(FileName: PWCHAR): HBITMAP;
  function  WinProc(Wnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD; stdcall;
  procedure TimerProc(Wnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
public
  CanDestroy: BOOL;
  Handle: THANDLE;
  OnStop: TStopEvent;       // Evento: Cuando la pelota se para
  OnWall: TWallEvent;       // Evento: Cuando la pelota alcanza la pared
  OnMissing: TMissingEvent; // Evento: Cuando la pelota sale fuera de su parent
  X,Y: double;    // Posición precisa de la pelota
  Vox: double;    // Velocidad inicial X
  Voy: double;    // Velocidad inicial Y
  CF: double;     // Coefeciente de frenada en bote
 
  constructor Create(hParent: HWND; Visible: BOOL = true; AutoTimer: BOOL = false; FileName: PWCHAR = nil);
  destructor  Destroy; override;
 
  procedure Move(t: double);       // Movimiento en un tiempo t
  procedure SetVisible(V: BOOL);   // Visibilidad
  procedure SetAutoTimer(V: BOOL); // Timer interno
end;
 
 
// GDI+ Flat API...
function  GdiplusStartup(var GdiToken: DWORD; Startup, Output: PBYTE): Cardinal; stdcall external 'gdiplus';
procedure GdiplusShutdown(GdiToken: DWORD); stdcall external 'gdiplus';
function  GdipCreateBitmapFromHBITMAP(hbm: HBITMAP; hpal: HPALETTE; var GBitmap: THANDLE): Cardinal; stdcall external 'gdiplus';
function  GdipCreateHBITMAPFromBitmap(GBitmap: THANDLE; var hBitmap: HBITMAP; BKColor: DWORD): DWORD; stdcall external 'gdiplus';
function  GdipDisposeImage(image: THANDLE): Cardinal; stdcall external 'gdiplus';
function  GdipImageRotateFlip(image: THANDLE; rfType: Cardinal): Cardinal; stdcall external 'gdiplus';
function  GdipCreateFromHDC(DC: HDC; var Graphics: Pointer): Cardinal; stdcall external 'gdiplus';
function  GdipRotateWorldTransform(graphics: Pointer; angle: Single; order: Cardinal): Cardinal; stdcall external 'gdiplus';
function  GdipTranslateWorldTransform(graphics: Pointer; sx, sy: Single; order: Cardinal): Cardinal; stdcall external 'gdiplus';
function  GdipDrawImage(graphics: Pointer; image: THANDLE; sx, sy: Single): Cardinal; stdcall external 'gdiplus';
function  GdipDeleteGraphics(graphics: Pointer): Cardinal; stdcall external 'gdiplus';
function  GdipDrawImageRect(graphics: Pointer; Image: THANDLE; x, y, w, h: Single): Cardinal; stdcall external 'gdiplus';
 
function  GdipCreateBitmapFromFile(lpFileName: PWCHAR; var GBitmap: THANDLE): DWORD; stdcall external 'gdiplus';
 
 
implementation
{$R *.res}
 
function CreateHBITMAPFromFile(FileName: PWCHAR): HBITMAP;
var
  GBitmap: THANDLE;
begin
  Result:= 0;
  GdipCreateBitmapFromFile(FileName, GBitmap);
  GdipCreateHBITMAPFromBitmap(GBitmap, Result, 0);
  GdipDisposeImage(GBitmap);
end;
 
procedure RotateDC(DC: HDC; x, y, Angle: Single);
var
  Bitmap: HBITMAP;
  GBitmap: THANDLE;
  Graphics: Pointer;
  BitmapData: TagBITMAP;
  Rect: TRect;
begin
  Bitmap:= GetCurrentObject(DC, OBJ_BITMAP);
  GetObject(Bitmap, sizeof(TagBITMAP), @BitmapData);
  Rect.Left:= 0; Rect.Right:= BitmapData.bmWidth; Rect.Top:= 0; Rect.Bottom:= BitmapData.bmHeight;
  GdipCreateBitmapFromHBITMAP(Bitmap, 0, GBitmap);
  FillRect(DC, Rect, 0);
  GdipCreateFromHDC(DC, Graphics);
  GdipTranslateWorldTransform(Graphics, -x, -y, 0);
  GdipRotateWorldTransform(Graphics, Angle, 1);
  GdipTranslateWorldTransform(Graphics, x, y, 1);
  GdipDrawImage(Graphics, GBitmap, 0, 0);
  GdipDisposeImage(GBitmap);
  GdipDeleteGraphics(Graphics);
end;
 
//---------------------------------------------------------------------------
 
function sWinProc(Wnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD; stdcall;
var
  Pelota: TPelota;
begin
  Pelota:= TPelota(GetWindowLong(Wnd, GWL_USERDATA));
  if Pelota <> nil then
    Result:= Pelota.WinProc(Wnd, uMsg, wParam, lParam)
  else
    Result:= DefWindowProc(Wnd, uMsg, wParam, lParam);
end;
 
procedure sTimerProc(Wnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
var
  Pelota: TPelota;
begin
  Pelota:= TPelota(idEvent);
  if Pelota <> nil then
    Pelota.TimerProc(Wnd, uMsg, idEvent, dwTime);
end;
//---------------------------------------------------------------------------
 
const Interval = 20;
 
constructor TPelota.Create(hParent: HWND; Visible: BOOL = true; AutoTimer: BOOL = false; FileName: PWCHAR = nil);
var
  GdiPlusStartupInput: array[0..1] of int64;
  bm: TBITMAP;
  WinClass: TWNDCLASS;
  Rgn: HRGN;
begin
  // Inicializamos GDI+.
  GdiPlusStartupInput[0]:= 1; GdiPlusStartupInput[1]:= 0;
  GdiplusStartup(gdiplusToken, @GdiPlusStartupInput, nil);
 
  CanDestroy:= true; // Si false, no se destruye con WM_DESTROY
  OnWall:= nil;      // Evento: Cuando la pelota alcanza la pared
  OnMissing:= nil;   // Evento: Cuando la pelota sale fuera de su parent
  OnStop:= nil;      // Evento: Cuando la pelota se para
  Left:= 0;          // Posición de la Pelota en pantalla
  Top:= 0;
  FR:= 0;            // Factor de rotación
  Ao:= 0;            // Angulo inicial de rotación de la pelota
  X:= Left;          // Posición de la Pelota alta precisión
  Y:= Top;
  CF:= 0.98;         // Coeficiente de frenada en rebote
  Vox:= 1000;        // Velocidad inicial X
  Voy:= 0;           // Velocidad inicial Y
 
  // Cargar Bitmaps
  Bitmap:= CreateBitmap(FileName);
  BitmapBak:= CreateBitmap(FileName);
 
  // Obtengo DCs de Bitmaps y su tamaño
  BitmapDC:= CreateCompatibleDC(0);
  DeleteObject(SelectObject(BitmapDC, Bitmap));
  GetObject(Bitmap, sizeof(bm), @bm);
  BitmapDCBak:= CreateCompatibleDC(0);
  DeleteObject(SelectObject(BitmapDCBak, BitmapBak));
  Width:=  bm.bmWidth;
  Height:= bm.bmHeight;
 
  //Creamos la ventana
  ZeroMemory(@WinClass, sizeof(WinClass));
  WinClass.lpfnWndProc:= @sWinProc;
  WinClass.lpszClassName:= 'PelotaClass';
  RegisterClass(WinClass);
  Handle:= CreateWindowEx(WS_EX_TOOLWINDOW, WinClass.lpszClassName, 'Ball', WS_CHILD,
                        0, 0, Width, Height, hParent, 0, 0, nil);
  // Guardo el puntero this para acceder a esta clase desde funcion miembro static sWinProc
  SetWindowLong(Handle, GWL_USERDATA, LongInt(self));
 
  // Hago una región redonda
  Rgn:= CreateRoundRectRgn(1, 1, Width+1, Height+1, Width, Height);
  SetWindowRgn(Handle, Rgn, true);
  DeleteObject(Rgn);
 
  SetWindowPos(Handle, HWND_TOPMOST, 0,0,0,0, SWP_SHOWWINDOW or SWP_NOSIZE or SWP_NOMOVE);
  CR:= 90.0/Width; // Cte de rotación : 360/(PI*Image->Width);
 
  SetAutoTimer(AutoTimer);
  SetVisible(Visible);
end;
 
destructor TPelota.Destroy;
begin
  DeleteObject(Bitmap);
  DeleteDC(BitmapDC);
  DeleteObject(BitmapBak);
  DeleteDC(BitmapDCBak);
 
  // Shutdown GDI+
  GdiplusShutdown(gdiplusToken);
end;
 
function Sign(d: double): integer;
var
  R: PDWORD;
begin
  Result:= 1;         // asumo que es positivo
  R:= PDWORD(@d);
  inc(R);
  if ((R^ shr 31) and 1) = 1 then Result:= -1;  // Es negativo
  if d = 0 then Result:= 0;
end;
 
// Moviendo la pelota en un tiempo t
procedure TPelota.Move(t: double);
var
  Rgn: HRGN;
  DC: HDC;
  ParentRect: TRect;
  Vy, Xi, A: double;
begin
  if GetParent(Handle) = 0 then exit;
 
  GetClientRect(GetParent(Handle), ParentRect);
 
  Rebote:= true;
  Vy:= 9.8*t;      // Incremento de velocidad vertical;
  Xi:= Vox*t;      // Incremento de X horizontal
 
  // Posición de la pelota en un incremento de tiempo
  Y:= Y + 600*(Vy+Voy)*t;  // El valor 600 es una escala
  X:= X + Xi;              // Guardo la nueva posición
  Voy:= Voy + Vy;          // Guardo la nueva velocidad de la pelota
 
  // Angulo de rotación
  A:= Ao + Xi*CR*FR;
  Ao:= A;
 
  // Rebote con el techo
  if Y < 0 then
  begin
    if @OnWall <> nil then OnWall(self, Techo, Rebote);
    if Rebote then
    begin
      Y:= 0;
      FR:= 0; // Factor de rotación en rebote
      Voy:= -Voy*CF;  // reducción Y
      Vox:= Vox*CF;   // reducción X
    end;
  end;
  // Salida por el techo
  if ((Y + Height) < 0) and (@OnWall <> nil) then
    OnMissing(self, Techo);
 
  // Rebote en el suelo
  if (Y + Height) >= ParentRect.bottom then
  begin
    if @OnWall <> nil then OnWall(self, Suelo, Rebote);
    if Rebote then
    begin
      Y:= ParentRect.bottom - Height;
      FR:= 1/(1+Voy); // Factor de rotación en rebote
      Voy:= -Voy*CF;  // reducción Y
      Vox:= Vox*CF;   // reducción X
    end;
  end;
  // Salida por el suelo
  if (Y >= ParentRect.bottom) and (@OnMissing <> nil) then
    OnMissing(self, Suelo);
 
  // Rebote con el pared izquierda
  if (X <= 0) then
  begin
    if @OnWall <> nil then OnWall(self, ParedIzquierda, Rebote);
    if Rebote then
    begin
      X:= 0;
      FR:= -FR*Sign(Voy)*Vox/1600;
      if CF<1 then Voy:= Voy-FR*Vox/1000;
      Voy:= Voy*CF;    // reducción Y
      Vox:= -Vox*CF;   // reducción X
    end;
  end;
  // Salida por la pared izquierda
  if ((X + Width) <= 0) and (@OnMissing <> nil) then
     OnMissing(self, ParedIzquierda);
 
  // Rebote con el pared derecha
  if (X + Width) >= ParentRect.right then
  begin
    if @OnWall <> nil then OnWall(self, ParedDerecha, Rebote);
    if Rebote then
    begin
      X:= ParentRect.right - Width;
      FR:= FR*Sign(Voy)*Vox/1600;
      if CF<1 then Voy:= Voy+FR*Vox/1000;
      Voy:= Voy*CF;    // reducción Y
      Vox:= -Vox*CF;   // reducción X
    end;
  end;
  // Salida por la pared derecha
  if (X >= ParentRect.right) and (@OnMissing <> nil) then
     OnMissing(self, ParedDerecha);
 
  // Cuando se para en el suelo
  if (Left = trunc(X)) and (Top = ParentRect.bottom - Height) and (@OnStop <> nil) then
    OnStop(self);
 
  // Posiciono la pelota
  Left:= trunc(X);
  Top:=  trunc(Y);
  MoveWindow(Handle, Left, Top, Width, Height, true);
 
  // Rotación de la pelota
  BitBlt(BitmapDC, 0, 0, Width, Height, BitmapDCBak, 0, 0, SRCCOPY);
  RotateDC(BitmapDC, Width/2, Height/2, A);
  // ... y la pinto...
  DC:= GetDC(Handle);
  BitBlt(DC, 0, 0, Width, Height, BitmapDC, 0, 0, SRCCOPY);
  ReleaseDC(Handle, DC);
end;
 
procedure TPelota.SetVisible(V: BOOL);
begin
  if V then
  begin
    SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) or WS_VISIBLE);
    SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_SHOWWINDOW or SWP_NOSIZE or SWP_NOMOVE);
  end
  else
    SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and not WS_VISIBLE);
end;
 
// Timer interno
procedure TPelota.SetAutoTimer(V: BOOL);
begin
  AutoTimer:= V;
  if AutoTimer then
    SetTimer(Handle, UINT_PTR(self), Interval, @sTimerProc)
  else KillTimer(Handle, UINT_PTR(self));
end;
 
procedure TPelota.TimerProc(Wnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
begin
  Move(Interval/1000.0);
end;
 
function TPelota.WinProc(Wnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD; stdcall;
var
  ps: PAINTSTRUCT;
  DC: HDC;
begin
  Result:= 0;
  case uMsg of
    WM_PAINT:
    begin
      DC:= BeginPaint(Wnd, ps);
      BitBlt(DC, 0, 0, Width, Height, BitmapDC, 0, 0, SRCCOPY);
      EndPaint(Wnd, ps);
    end;
    WM_DESTROY:
      if CanDestroy then
        PostQuitMessage(0);                //Destruimos la ventana
    else
      // Función por defecto de tratamiento de mensajes.
        Result:= DefWindowProc(Wnd, uMsg, wParam, lParam);
  end;
end;
//---------------------------------------------------------------------------
 
function TPelota.CreateBitmap(FileName: PWCHAR): HBITMAP;
var
  DC: HDC;
begin
  if FileName = nil then
    Result:= LoadBitmap(GetModuleHandle(nil), 'ID_PELOTA')
  else
    Result:= CreateHBITMAPFromFile(FileName);
  if Result = 0 then
  begin
    // Si no hay Bitmap creo uno vacio
    DC:= GetDC(0);
    Result:= CreateCompatibleBitmap(DC, 51, 51);
    ReleaseDC(0, DC);
  end;
end;
 
end.

Ahora os muestro una broma de pelotas

delphi

program Pelotas;
 
uses
  Windows,
  Messages,
  Pelota in 'Pelota.pas';
 
type
TBroma = class
  private
    Count: integer;
  public
    constructor Create;
    procedure PelotaStop(Pelota: TPelota);
end;
 
constructor TBroma.Create;
begin
  Count:= 0;
  with TPelota.Create(GetDesktopWindow(), true, true) do 
  begin
    CanDestroy:= false;
    OnStop:= PelotaStop;
    CF:= 0.95;
  end;
  with TPelota.Create(GetDesktopWindow(), true, true, 'Pelota7.png') do
  begin
    CanDestroy:= false;
    CF:= 1;
    Vox:= 700;     // Velocidad inicial X
  end;
end;
 
procedure TBroma.PelotaStop(Pelota: TPelota);
begin
  with Pelota do
  begin
    X:= 0;
    Y:= 0;
    Vox:= 900 + random(300);     // Velocidad inicial X
    Voy:= 0;
    if Count > 3 then
    Voy:= 10;
    CF:= 0.95;
  end;
 
  if Count > 5 then exit;
  inc(Count);
 
  with TPelota.Create(GetDesktopWindow(), true, true) do
  begin
    CanDestroy:= false;
    CF:= 1;
    Vox:= Pelota.Vox;     // Velocidad inicial X
  end;
end;
 
 
var
  Msg: TMsg;
  Broma: TBroma;
begin
  TBroma.Create();
 
  // El bucle de mensajes
  while(GetMessage(Msg, 0, 0, 0)) do
  begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
end.

Subo el código y ejecutable.

Saludos.

Archivos adjuntos

Pelotas.rar 35,77KB 28 descargas

#95714 Delphi Academy - Latinoamérica

Escrito por egostar el 07 octubre 2016 - 03:56

Pues eso.....

Consejos prácticos de programación, trucos y técnicas que se pueden utilizar ahora! Usted está invitado a unirse a los expertos de Embarcadero cada 15 días para tutoriales de 30 minutos sobre el desarrollo de software para Windows, Mac, Android y iOS.

Calendario completo y el registro

Saludos

Contenido con la más alta reputación

Archivos adjuntos

Archivos adjuntos

Archivos adjuntos

Archivos adjuntos

Archivos adjuntos

Archivos adjuntos

Archivos adjuntos

Archivos adjuntos

Iniciar sesión