Delphi Basics Snippets - DelphiBasics

Voik Func In

posted 26 Jan 2012, 13:45 by Delphi Basics

This unit has been coded to facilitate simple use of the otherwise advanced "Func In" technique.

Functions can be written normally. This version also supports:

+ Static strings

+ Functions calls

+ Parameters

Client Example:

program Client;

//Voik

uses

Windows,

VoikClientFuncIn;

function IsDebuggerPresent(): Boolean; stdcall; external kernel32 name 'IsDebuggerPresent';

procedure AntiDebugger1(Parameters: Pointer); stdcall;

begin

if IsDebuggerPresent() then

ExitProcess(0);

end;

procedure AntiDebugger2(Parameters: Pointer); stdcall;

begin

OutputDebugString('%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s');

end;

procedure ShowMessage(Parameters: Pointer); stdcall;

begin

MessageBox(0, pChar(Parameters), 'Voik', MB_OK);

end;

const

MSG = 'No debbuger!';

var

FuncIn: TVoikFuncIn;

begin

FuncIn := TVoikFuncIn.Create('Stub.exe');

FuncIn.AddFunction(AntiDebugger1);

FuncIn.AddFunction(AntiDebugger2);

FuncIn.AddFunction(ShowMessage, pChar(MSG), Length(MSG) + 1);

FuncIn.SaveFunctions();

end.

Respective Server Example:

program Stub;

//Voik

uses

VoikServerFuncIn;

begin

VoikFuncIn();

end.

Only delphi source code is included in the archive.

| Attachments: VoikFuncIn.rar

uGetProcess - Retrieve Injectable 32-bit Process

posted 26 Nov 2011, 10:15 by Delphi Basics

This Unit is Made by Snify and MindfreaK together.

We went bored and searched for an x64 persistence method.

U can easily write your own x64 persistence with this ,

just write ur persistence dll or codeinjection and inject it

into an process u have found with GetInjectAbleProcess.

WARNING: Remember, the Process is chosen randomly and could be terminated

by itself , so u need an re-inject system which checks for an running

persistence module/dll/codeinjection. ( TIPP: Communicate via Mutex )

{

This Unit is Made by Snify and MindfreaK together.

We went bored and searched for an x64 persistence method.

U can easily write your own x64 persistence with this ,

just write ur persistence dll or codeinjection and inject it

into an process u have found with GetInjectAbleProcess.

WARNING: Remember, the Process is chosen randomly and could be terminated

by itself , so u need an re-inject system which checks for an running

persistence module/dll/codeinjection. ( TIPP: Communicate via Mutex )

- OpenSC.WS -

}

unit uGetProcess;

interface

uses SysUtils,TlHelp32,Windows;

function GetInjectAbleProcess() : Integer;

implementation

type

PTOKEN_USER = ^TOKEN_USER;

_TOKEN_USER = record

User: TSidAndAttributes;

end;

TOKEN_USER = _TOKEN_USER;

function GetUserAndDomainFromPID(ProcessId: DWORD;

var User, Domain: string): Boolean;

var

hToken: THandle;

cbBuf: Cardinal;

ptiUser: PTOKEN_USER;

snu: SID_NAME_USE;

ProcessHandle: THandle;

UserSize, DomainSize: DWORD;

bSuccess: Boolean;

begin

Result := False;

ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);

if ProcessHandle <> 0 then

begin

// EnableProcessPrivilege(ProcessHandle, 'SeSecurityPrivilege', True);

if OpenProcessToken(ProcessHandle, TOKEN_QUERY, hToken) then

begin

bSuccess := GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf);

ptiUser := nil;

while (not bSuccess) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) do

begin

ReallocMem(ptiUser, cbBuf);

bSuccess := GetTokenInformation(hToken, TokenUser, ptiUser, cbBuf, cbBuf);

end;

CloseHandle(hToken);

if not bSuccess then

begin

Exit;

end;

UserSize := 0;

DomainSize := 0;

LookupAccountSid(nil, ptiUser.User.Sid, nil, UserSize, nil, DomainSize, snu);

if (UserSize <> 0) and (DomainSize <> 0) then

begin

SetLength(User, UserSize);

SetLength(Domain, DomainSize);

if LookupAccountSid(nil, ptiUser.User.Sid, PChar(User), UserSize,

PChar(Domain), DomainSize, snu) then

begin

Result := True;

User := StrPas(PChar(User));

Domain := StrPas(PChar(Domain));

end;

if bSuccess then

begin

FreeMem(ptiUser);

end;

CloseHandle(ProcessHandle);

end;

function IsWOW64: Boolean;

type

TIsWow64Process = function(Handle: THandle;var Res: BOOL): BOOL; stdcall;

var

IsWow64Result: BOOL;

IsWow64Process: TIsWow64Process;

begin

IsWow64Process := GetProcAddress(

GetModuleHandle('kernel32'), 'IsWow64Process'

);

if Assigned(IsWow64Process) then

begin

IsWow64Process(GetCurrentProcess, IsWow64Result);

Result := IsWow64Result;

end

else

Result := False;

end;

Function GetUserFromWindows: string;

Var

UserName : string;

UserNameLen : Dword;

Begin

UserNameLen := 255;

SetLength(userName, UserNameLen) ;

If GetUserName(PChar(UserName), UserNameLen) Then

Result := Copy(UserName,1,UserNameLen - 1)

Else

Result := 'Unknown';

End;

function GetInjectAbleProcess() : Integer; // 32 bit only

var

bProcess: boolean;

hProcess: THandle;

pe32Structur: TProcessEntry32;

sUser: string;

sDomain: string;

sWindowsUser: string;

TIsWow64Process : function( Handle: Windows.THandle; var Res: Windows.BOOL): Windows.BOOL; stdcall;

hOpen: THandle;

bIsWOW64: BOOL;

bError: boolean;

array_PID : array of integer;

pidcounter : Integer;

begin

pidcounter := 0;

sWindowsUser := GetUserFromWindows;

pe32Structur.dwSize:=Sizeof(TProcessEntry32);

hProcess :=CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);

If IsWow64 = true then

begin

TIsWow64Process := GetProcAddress(GetModuleHandle('kernel32'), 'IsWow64Process');

if Assigned(TIsWow64Process) then

begin

// Writeln ( 'API geladen.' )

end;

if Process32first(hProcess,pe32structur) then

begin

//Writeln ( IntToStr (pe32Structur.th32ProcessID) );

repeat bProcess:=Process32Next(hProcess,pe32structur);

if GetCurrentProcessID <> pe32Structur.th32ProcessID then

begin

bError := false;

if bProcess = true then

begin

GetUserAndDomainFromPID(pe32Structur.th32ProcessID,sUser, sDomain);

if sWindowsUser = sUser then

begin

if IsWOW64 = true then //wenn 64

begin

//Writeln ('OpenProcess: '+IntToStr(pe32Structur.th32ProcessID));

                 hOpen :=  Windows.OpenProcess ( PROCESS_QUERY_INFORMATION , false , pe32Structur.th32ProcessID );

if hOpen = 0 then

begin

//Writeln ('OpenProcess gescheitert.');

bError := true;

end;

if bError = false then

begin

TIsWow64Process ( hOpen , bIsWOW64 );

CloseHandle ( hOpen );

if bIsWOW64 = false then

begin

// Writeln ( '64Bit: '+IntToStr(pe32Structur.th32ProcessID) )

end;

if bIsWOW64 = true then

begin

//Writeln ( {'32Bit: '+}IntToStr(pe32Structur.th32ProcessID) );

SetLength(array_PID, pidcounter+1);

array_PID[pidcounter] := pe32Structur.th32ProcessID;

inc(pidcounter);

end;

if ISWOW64 = false then //Wenn 32

begin

//Writeln ( IntToStr (pe32Structur.th32ProcessID) );

SetLength(array_PID, pidcounter+1);

array_PID[pidcounter] := pe32Structur.th32ProcessID;

inc(pidcounter);

end;

until not bProcess;

end;

CloseHandle ( hProcess );

{$IFDEF Debug}

for pidcounter := 0 to Length(array_PID) -1 do begin

writeln ('INDEX['+inttostr(pidcounter)+'] ' + inttostr(array_PID[pidcounter]));

end;

{$ENDIF}

randomize;

result := array_PID[1 + random (Length(array_PID)-1)];

end;

end.

Smallest System.pas and SysInit.pas - Windows XP, Vista & 7

posted 4 Aug 2011, 12:45 by Delphi Basics

Inspired by Small Applications in Delphi - Tutorial by n0v4, these "Mini-Delphi" units (identification by PEiD) have been updated to work with all Windows NT operating systems.

System.pas

unit System;

interface

procedure _Halt0;

procedure _HandleFinally;

type

TGUID = record

D1: LongWord;

D2: Word;

D3: Word;

D4: array [0..7] of Byte;

end;

var

ExitCode: Integer = 0;

procedure ExitProcess(ExitCode: Integer); stdcall; external 'kernel32.dll' name 'ExitProcess';

implementation

procedure _Halt0;

begin

ExitProcess(ExitCode);

end;

procedure _HandleFinally;

asm

end;

end.

SysInit.pas

unit SysInit;

interface

procedure _InitExe(InitTable: Pointer);

var

TlsIndex: Integer = -1;

TlsLast: Byte;

const

PtrToNil: Pointer = nil;

implementation

procedure _InitExe(InitTable: Pointer);

begin

end;

end.

Glass Effect in a Delphi Console Application

posted 4 Aug 2011, 12:35 by Delphi Basics

To apply a nice glass effect to our console applications we must use the DwmEnableBlurBehindWindow function (Only available in Windows Vista and Windows 7).

http://msdn.microsoft.com/en-us/library/aa969508(VS.85).aspx

Author: Rodrigo Ruz

program ConsoleGlassDelphi;

//Author : Rodrigo Ruz 2009-10-26

{$APPTYPE CONSOLE}

uses

Windows,

SysUtils;

type

DWM_BLURBEHIND = record

dwFlags : DWORD;

fEnable : BOOL;

hRgnBlur : HRGN;

fTransitionOnMaximized : BOOL;

end;

function DwmEnableBlurBehindWindow(hWnd : HWND; const pBlurBehind : DWM_BLURBEHIND) : HRESULT; stdcall; external  'dwmapi.dll' name 'DwmEnableBlurBehindWindow';//function to enable the glass effect

function GetConsoleWindow: HWND; stdcall; external kernel32 name 'GetConsoleWindow'; //get the handle of the console window

function DWM_EnableBlurBehind(hwnd : HWND; AEnable: Boolean; hRgnBlur : HRGN = 0; ATransitionOnMaximized: Boolean = False; AFlags: Cardinal = 1): HRESULT;

var

pBlurBehind : DWM_BLURBEHIND;

begin

pBlurBehind.dwFlags:=AFlags;

pBlurBehind.fEnable:=AEnable;

pBlurBehind.hRgnBlur:=hRgnBlur;

pBlurBehind.fTransitionOnMaximized:=ATransitionOnMaximized;

Result:=DwmEnableBlurBehindWindow(hwnd, pBlurBehind);

end;

begin

try

DWM_EnableBlurBehind(GetConsoleWindow(), True);

Writeln('See my glass effect');

Writeln('Go Delphi Go');

Readln;

except

on E:Exception do

Writeln(E.Classname, ': ', E.Message);

end;

end.

Detect Aero Glass using Delphi

posted 4 Aug 2011, 12:34 by Delphi Basics

To detect if Aero Glass is enabled we must use the DwmIsCompositionEnabled function.

http://msdn.microsoft.com/en-us/library/aa969518(VS.85).aspx

Author: Rodrigo Ruz

program DetectAeroDelphi;

{$APPTYPE CONSOLE}

//Author Rodrigo Ruz 2009-10-26

uses

Windows,

SysUtils;

function ISAeroEnabled: Boolean;

type

_DwmIsCompositionEnabledFunc = function(IsEnabled: PBoolean): HRESULT; stdcall;

var

Flag : Boolean;

DllHandle : THandle;

OsVersion : TOSVersionInfo;

DwmIsCompositionEnabledFunc: _DwmIsCompositionEnabledFunc;

begin

Result:=False;

ZeroMemory(@OsVersion, SizeOf(OsVersion));

OsVersion.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);

  if ((GetVersionEx(OsVersion)) and (OsVersion.dwPlatformId = VER_PLATFORM_WIN32_NT) and (OsVersion.dwMajorVersion >= 6)) then //is Vista or Win7?

begin

DllHandle := LoadLibrary('dwmapi.dll');

if DllHandle <> 0 then

begin

@DwmIsCompositionEnabledFunc := GetProcAddress(DllHandle, 'DwmIsCompositionEnabled');

if (@DwmIsCompositionEnabledFunc <> nil) then

begin

DwmIsCompositionEnabledFunc(@Flag);

Result:=Flag;

end;

FreeLibrary(DllHandle);

end;

begin

try

if ISAeroEnabled then

Writeln('Aero Glass enabled')

else

Writeln('Aero Glass disabled');

Readln;

except

on E:Exception do

Writeln(E.Classname, ': ', E.Message);

end;

end.

Using NtDeleteFile from Delphi

posted 4 Aug 2011, 12:27 by Delphi Basics

The native API NtDeleteFile performs the same task as the user-mode API DeleteFile, but interestingly enough, the user-mode API does not call the native API to perform it’s task. As explained here, normally files are deleted through calls to NtSetInformationFile. The main difference in behavior comes from the fact that NtDeleteFile does not wait for handles on the file to close before deleting it (note that if the file is “open for normal I/O or as a memory-mapped file”, it still can’t be deleted, so only read-only handles will be ignored).

Source:

http://vtopan.wordpress.com/2009/05/26/using-ntdeletefile-from-delphi/

The required structures (not defined in Delphi) are:

UNICODE_STRING

PUNICODE_STRING = ^UNICODE_STRING;

UNICODE_STRING = packed record

Length: Word;

MaximumLength: Word;

Buffer: PWideChar;

end;

OBJECT_ATTRIBUTES.

POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES;

OBJECT_ATTRIBUTES = packed record

Length: Cardinal;

RootDirectory: THandle;

ObjectName: PUNICODE_STRING;

Attributes: Cardinal;

SecurityDescriptor: Pointer;

SecurityQualityOfService: Pointer;

end;

The steps to remove the file are:

Convert the “DOS” path name to an “NT” path name (basically prepend “\??\” to whatever the plain path is) using RtlDosPathNameToNtPathName_U;
Fill in the OBJECT_ATTRIBUTES structure;
Call NtDeleteFile.

Using the afore-linked-to type definitions, we still need to import the native APIs:

function NtDeleteFile(ObjectAttributes:POBJECT_ATTRIBUTES):DWORD; stdcall; external 'ntdll.dll';

function RtlDosPathNameToNtPathName_U(DosName:PWChar; var NtName:UNICODE_STRING; DosFilePath:PPChar; NtFilePath:PUNICODE_STRING):BOOL; stdcall; external 'ntdll.dll';

Do note that this statically links the imported functions, making the whole application unable to load if the undocumented APIs are not present on the system (at least for Windows 2000 and XP they should be).

Converting the DOS path name to a native path is done by the RtlDosPathNameToNtPathName_U API, which takes in a PWChar argument containing the DOS path and a pre-allocated UNICODE_STRING structure of MAX_PATH WideChars and returns True if it has successfully converted the path.

program NativeDelete;

//cswi - www.delphibasics.info

//Vlad Ioan Topan - http://vtopan.wordpress.com

uses

Windows;

type

PUnicodeString = ^TUnicodeString;

TUnicodeString = packed record

Length: Word;

MaximumLength: Word;

Buffer: PWideChar;

end;

PObjectAttributes = ^TObjectAttributes;

TObjectAttributes = packed record

Length: Cardinal;

RootDirectory: THandle;

ObjectName: PUnicodeString;

Attributes: Cardinal;

SecurityDescriptor: Pointer;

SecurityQualityOfService: Pointer;

end;

procedure RtlInitUnicodeString(DestinationString: PUnicodeString; SourceString: LPWSTR); stdcall; external 'ntdll.dll';

function NtDeleteFile(ObjectAttributes: PObjectAttributes): DWORD; stdcall; external 'ntdll.dll';

function RtlDosPathNameToNtPathName_U(DosName: PWChar; var NtName: TUnicodeString; DosFilePath: PPChar; NtFilePath: PUnicodeString):BOOL; stdcall; external 'ntdll.dll';

procedure InitializeObjectAttributes(var InitializedAttributes: TObjectAttributes;

ObjectName: PUnicodeString;

Attributes: ULONG;

RootDirectory: THandle;

SecurityDescriptor: Pointer;

SecurityQualityOfService : Pointer);

begin

InitializedAttributes.Length := SizeOf(TObjectAttributes);

InitializedAttributes.RootDirectory := RootDirectory;

InitializedAttributes.Attributes := Attributes;

InitializedAttributes.ObjectName := ObjectName;

InitializedAttributes.SecurityDescriptor := SecurityDescriptor;

InitializedAttributes.SecurityQualityOfService := SecurityQualityOfService;

end;

function _DeleteFile(wsFileName: WideString):DWORD;

var

ObjectAttributes: TObjectAttributes;

UnicodeString: TUnicodeString;

begin

Result := $C0000001; // STATUS_UNSUCCESSFUL, "generic" error

RtlInitUnicodeString(@UnicodeString, @wsFileName);

RtlDosPathNameToNtPathName_U(@wsFileName[1], UnicodeString, nil, nil);

InitializeObjectAttributes(ObjectAttributes, @UnicodeString, $40, 0, nil, nil);

Result := NtDeleteFile(@ObjectAttributes); // pass on the NTSTATUS

end;

const

wsFileName : PWideChar = 'C:\GoogleLogo.png';

begin

_DeleteFile(wsFileName);

end.

Undocumented MessageBoxTimeOut function

posted 4 Aug 2011, 12:26 by Delphi Basics

There are lots of neat little things that are in many of the DLLs that Microsoft has installed in Windows. Most of them are documented in the Win32 API. However, there are a lot of them that are undocumented. This article shows how to use one of the undocumented functions available in user32.dll, MessageBoxTimeOut.

This type of functionality for a MessageBox has been requested on the Delphi newsgroups many times and there have been several solutions written. After being introduced in XP, this functionality is now available to developers using this undocumented API.

Source:

http://www.delphi3000.com/articles/article_4808.asp

Author:

Jens Borrisholt

Since this function is not documented, it is not found in Windows.pas, so it has to be defined. It is identical to the MessageBox API definition except it has two more parameters, wLanguageID and dmMilliseconds.

function MessageBoxTimeOut(

hWnd: HWND; lpText: PChar; lpCaption: PChar;

uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

function MessageBoxTimeOutA(

hWnd: HWND; lpText: PChar; lpCaption: PChar;

uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

function MessageBoxTimeOutW(

hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;

uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

implementation

// this const is not defined in Windows.pas

const

MB_TIMEDOUT = 32000;

function MessageBoxTimeOut; externaluser32 name 'MessageBoxTimeoutA';

function MessageBoxTimeOutA; external user32 name 'MessageBoxTimeoutA';

function MessageBoxTimeOutW; external user32 name 'MessageBoxTimeoutW';

Now, to call the function, it is as easy as setting the flags and making the call. There may be other results returned that I am not aware of besides the standard IDxxx return values and the MB_TIMEDOUT result defined above.

var

iResult: Integer;

iFlags: Integer;

begin

// Define a MessagBox with an OK button and a timeout of 2 seconds

iFlags := MB_OK or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;

iResult := MessageBoxTimeout(

Application.Handle,

'Test a timeout of 2 seconds.',

'MessageBoxTimeout Test', iFlags, 0, 2000);

// iResult will = 1 (IDOK)

ShowMessage(IntToStr(iRet));

// Define a MessageBox with a Yes and No button and a timeout of 5 seconds

iFlags := MB_YESNO or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;

iResult := MessageBoxTimeout(

Application.Handle,

'Test a timeout of 5 seconds.',

'MessageBoxTimeout Test', iFlags, 0, 5000);

// iResult = MB_TIMEDOUT if no buttons clicked, otherwise

// iResult will return the value of the button clicked

case iResult of

IDYES: // Pressed Yes button

ShowMessage('Yes');

IDNO: // Pressed the No button

ShowMessage('No');

MB_TIMEDOUT: // MessageBox timed out

ShowMessage('TimedOut');

end;

I presume Borland will not put this into Windows.pas until Microsoft documents it but developers can get a head start on them by using the code above. It is unlikely that Microsoft will depricate this function for quite some time because all of the standard MessageBox API calls actually call MessageBoxTimeOutA or MessageBoxTimeoutW and pass $FFFFFFFF as the timeout period meaning the dialog will wait a very long time, approx 49 days!

Screen Scanner - Psychlo

posted 28 Jul 2011, 11:46 by Delphi Basics

"Just got inspired last night and decided to start a class to get the screen in "blocks" and check which one has changed to update only those."

(* ********************************

* uScreenScanner.pas *

* version: 1.0 *

* by Psychlo *

* *

* 15/07/2011 *

* ic0de.org *

* *

* Music: Breaking Benjamin *

* *

* Add me into the credits of *

* your RAT ;) *

* *

* Thanks to: *

* iC0de Community *

* Torry's Delphi Page *

* givex8 *

* Protocol *

* dn5 *

******************************** *)

unit uScreenScanner;

interface

uses

Windows, SysUtils, Graphics;

const

ERRORMSG_INCORRECT_WIDTH = 'Width must be multiple of 8!';

ERRORMSG_INCORRECT_HEIGHT = 'Height must be multiple of 8!';

type

TBmpPack = packed record

Bmp: TBitmap;

Modified: Boolean;

end;

TBmpArray = Array of TBmpPack;

TScreenScanner = class

private

fDivScreen: Integer;

fScreenWidth, fScreenHeight: Integer;

fWatchRect: TRect;

fScreenArray: Array of TBmpArray;

function CompareBitmap(Bmp1, Bmp2 : TBitmap): Integer;

published

constructor Create(

const DivScreen: Integer = 8;

const X: Integer = 0;

const Y: Integer = 0;

const Width: Integer = 0;

const Height: Integer = 0

);

destructor Destroy; override;

procedure ScanScreen;

function GetSnapshot(lpRect: TRect): TBitmap;

function GetBitmapRect(lpRect: TRect; Bitmap: TBitmap): TBitmap;

function GetBmpPack(i, j: Integer): TBmpPack;

function IsBmpPackModified(i, j: Integer): Boolean;

property ColumnCount: Integer read fDivScreen;

property RowCount: Integer read fDivScreen;

property ScreenWidth: Integer read fScreenWidth;

property ScreenHeight: Integer read fScreenHeight;

end;

implementation

//... to be continued in attachment ;) ...

Basically this project does this:

Gets a snapshot of the screen;

Saves it in a matrix 8x8;

Updates the blocks that changes;

Shows the blocks in a reduced size to fit the form (about 2/3 of your resolution, but that is just me playing around).

So far I have done few tests. In a 1920x1080 and 3 secs update rate resolution considering compression capacity of 15%, gives me about 2~8kb/s for "small changes" in the screen. Of course that if the entire screen changes there are peaks. I found peaks of 400kb/s.

Only Delphi source code is included in the archive.

| Attachments: ScreenScanner.7z