Delphi Basics Snippets Archive: Archive: Delphi Basics Snippets |
Delphi Basics Snippets
Voik Func In
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. |
uGetProcess - Retrieve Injectable 32-bit Process
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; end; if bSuccess then begin FreeMem(ptiUser); end; end; CloseHandle(ProcessHandle); end; 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; 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; end; 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; end; end; 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
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
To apply a nice glass effect to our console applications we must use the DwmEnableBlurBehindWindow function (Only available in Windows Vista and Windows 7). 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
To detect if Aero Glass is enabled we must use the DwmIsCompositionEnabled function. 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; end; FreeLibrary(DllHandle); end; 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
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: 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:
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
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. 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; 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
"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. |
Dynamically Calling Windows Apis With Encryption
This short delphi snippet details dynamically calling windows apis with encryption. program DynamiqueAPI; //cswi //www.delphibasics.info uses Windows; type TMessageBoxA = function(Handle : Cardinal; lpText : PAnsiChar; lpCaption : PAnsiChar; uType : Cardinal) : Cardinal; stdcall; function EnDeCrypt(const Value : String) : String; var CharIndex : integer; begin Result := Value; for CharIndex := 1 to Length(Value) do Result[CharIndex] := chr(not(ord(Value[CharIndex]))); end; var hUser32 : Cardinal; xMessageBoxA : TMessageBoxA; sMessageBoxA : PAnsiChar; begin sMessageBoxA := PAnsiChar(EnDeCrypt('²šŒŒž˜š½‡¾')); hUser32 := LoadLibraryA('user32.dll'); @xMessageBoxA := GetProcAddress(hUser32, sMessageBoxA); if Assigned(xMessageBoxA) then xMessageBoxA(0, 'Hello World', '', 0); end. |
1-10 of 181