Screenschot machen und in einer Imagekomponente speichern
procedure TForm1.Button1Click(Sender: TObject);
var
ScreenDC: hDC;
TmpRect: TRect;
TmpBitmap: TBitmap;
begin
ScreenDC := GetDC(0);
TmpBitmap := TBitmap.Create;
TmpRect := Rect(0, 0, Screen.Width, Screen.Height);
TmpBitmap.Width := TmpRect.Right - TmpRect.Left;
TmpBitmap.Height := TmpRect.Bottom - TmpRect.Top;
try
BitBlt(TmpBitmap.Canvas.Handle, TmpRect.Left, TmpRect.Top,
TmpBitmap.Width, TmpBitmap.Height, ScreenDC,
TmpRect.Left, TmpRect.Top, SRCCOPY);
Image1.Picture.Bitmap.Assign(TmpBitmap);
finally
TmpBitmap.Free;
ReleaseDC(0, ScreenDC);
end;
end;
|
procedure ChangeIt;
var
Reg: TRegIniFile;
begin
Reg := TRegIniFile.Create('Control Panel');
Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\forest.bmp');
Reg.WriteString('desktop', 'TileWallpaper', '1');
Reg.Free;
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end;
|
Mit der Enter- anstatt mit der TAB-Taste das Feld wechseln
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin if Key = #13 then begin Self.Perform(WM_NEXTDLGCTL, 0, 0); Key := #0; end; end |
procedure TForm1.FormCreate(Sender: TObject); var HR: hRgn; n: array[0..3] of TPoint; begin n[0] := Point(Width div 2, 1); n[1] := Point(1, Height div 2); n[2] := Point(Width div 2, Height); n[3] := Point(Width, Height div 2); HR := CreateEllipticRgn(0, 0, Width, Height); SetWindowRgn(Handle, HR, True); end; |
im Projektquelltext nach CreateForm
begin Application.Initialize; Application.Title := 'Projekt1'; Application.CreateForm(TMain,Main); Application.ShowMainForm := False; Application.Run; end; |
procedure TForm1.FormShow(Sender: TObject); var Owner: hWnd; begin Owner := GetWindow(Handle, GW_OWNER); ShowWindow(Owner, SW_HIDE); end; |
Ein Programm im Taskmanager (Strg+Alt+Entf) verstecken
implementation
{$R *.DFM}
function RegisterServiceProcess(dwProcessID, dwType: DWord): DWord; stdcall;
external 'KERNEL32.DLL' name 'RegisterServiceProcess';
procedure TForm1.Create(Sender: TObject);
begin
RegisterServiceProcess(0, 1);
end;
|
Ein Label mit mehreren Zeilen erstellen
Label1.Caption := 'Zeile 1' + #13 + 'Zeile 2' + #13 + 'Zeile 3'; |
procedure TForm1.FormCreate(Sender: TObject); begin SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) AND NOT WS_CAPTION); ClientHeight := Height; Refresh; end; |
Nur Zahlen in einem Editfeld erlauben
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin if NOT (Key in ['0'..'9']) then Key := #0; end; |
Einen eigenen Cursor verwenden
Screen.Cursors[1] := LoadCursorFromFile('aim.Ani');
Cursor := 1;
|
Strg+Alt+Entf / Alt+TAB / Strg+ESC verhindern
VAR OldValue:Longbool; SystemParametersInfo(97,Word(True),@OldValue,0); //STRG+ALT+ENTF deaktiviert SystemParametersInfo(97,Word(False),@OldValue,0); //STRG+ALT+ENTF aktiviert |
with MyForm do
SetWindowPos(Handle,HWND_TOPMOST,Left,Top,Width,Height,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
|
Mit dem folgendem Code ist es möglich auch ein Formular mit BorderStyle bsNone zu bewegen
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin ReleaseCapture; Form1.perform(WM_SysCommand, $F012, 0); end; |
Hiermit kann man einen Button erstellen, wenn das Programm bereits gestartet wurde
Var MyButton : TButton; MyButton := TButton.Create(Form1);
with MyButton do
BEGIN
Parent := Form1;
height := 32;
width := 128;
caption := 'Button';
left := 50;
top := 50;
END;
|
Die Zeit, die seit dem Windowsstart vergangen ist im Label1 anzeigen
Label1.caption := IntToStr(GetTickCount); |
function EnumWinProc(Wnd : HWND) : Boolean; Export; StdCall;
var
WinText : Array[0..255] of Char;
begin
GetWindowText(Wnd, WinText, 255);
Result := True;
if (StrPas(WinText) <> '') and
IsWindowVisible(Wnd) and
(Wnd<>Application.Handle) and
(Wnd<>Form1.Handle)
then
CloseWindow(Wnd);
end;
EnumWindows(@EnumWinProc, LongInt(Self)); |
Ein Fenster transparent darstellen
Procedure MakeWindowTransparent (Form: TForm); Var CurrentStyle : LongInt; Begin Form.Visible := False; CurrentStyle := GetWindowLong(Form.Handle, GWL_EXSTYLE); SetWindowLong(Form.Handle, GWL_EXSTYLE, CurrentStyle Or WS_EX_TRANSPARENT); Form.Visible := True; End; |
procedure SysHideTaskbar;
var wndHandle : THandle;
begin
wndHandle := FindWindow(Pchar('Shell_TrayWnd'), nil);
ShowWindow(wndHandle, SW_HIDE);
end;
|
Taskbar zeigen
procedure SysShowTaskbar;
var wndHandle : THandle;
begin
wndHandle := FindWindow('Shell_TrayWnd', nil);
ShowWindow(wndHandle, SW_RESTORE);
end;
|
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin Canclose:=false; end; |
CD-Rom öffnen/schließen:
Füge 'MMSystem' in die uses ein und erstelle folgende Procedur
procedure OpenCd(AOpen:Boolean);
const
DoPlay : array[Boolean] of String =
('Set cdaudio door closed wait',
'Set cdaudio door open wait');
var
MyError : LongInt;
MyErrorString : array[0..MAXERRORLENGTH - 1] of char;
begin
MyError := mciSendString(pChar(DoPlay[AOpen]), nil, 0, 0);
if MyError <> 0 then
begin
MciGetErrorString(MyError,MyErrorString,MAXERRORLENGTH - 1);
Showmessage(MyErrorString);
Exit;
end;
end;
|
zum öffnen: zum schließen:
OpenCd(TRUE); OpenCd(TRUE); |
procedure myclass.buttonclick(Sender:tobject);
var WinDir:array[0..255]of char;
i:integer;
begin
i:=GetWindowsDirectory(WinDir,25); {WinDir is the Windows directory}
showmessage(WinDir);
end;
|
Ein Bild in die Zwischenablage kopieren
uses ClipBrd;
procedure CaptureForm;
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
Bitmap.Width := ClientWidth;
Bitmap.Height := ClientHeight;
try
with Bitmap.Canvas do
CopyRect(ClientRect, Canvas, ClientRect);
Clipboard.Assign(Bitmap);
finally
Bitmap.Free;
end;
end;
|
procedure TForm1.FormShow(Sender: TObject); var Owner: hWnd; begin Owner := GetWindow(Handle, GW_OWNER); ShowWindow(Owner, SW_HIDE); end; |
Ein Programm im Taskmanager (Strg+Alt+Entf) zu verstecken
implementation
{$R *.DFM}
function RegisterServiceProcess(dwProcessID, dwType: DWord): DWord; stdcall;
external 'KERNEL32.DLL' name 'RegisterServiceProcess';
procedure TForm1.Create(Sender: TObject);
begin
RegisterServiceProcess(0, 1);
end;
|
erstelle folgende Funktionen
const
{C1 y C2 are used for encryption of Master Password string}
C1 = 52845;
C2 = 11719;
{ Standard Decryption algorithm - Copied from Borland}
function Decrypt(const S: String; Key: Word): String;
var
I: byte;
begin
SetLength(Result,Length(S));
for I := 1 to Length(S) do begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(S[I]) + Key) * C1 + C2;
end;
end;
{ Standard Encryption algorithm - Copied from Borland}
function Encrypt(const S: String; Key: Word): String;
Var
I: byte;
begin
SetLength(Result,Length(S));
for I := 1 to Length(S) do begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(Result[I]) + Key) * C1 + C2;
end;
end;
|
Label1 entschlüsseln
Label1.Caption:= Encrypt(Label1.Caption,6474); |
Label1 verschlüsseln
Label1.Caption:= Decrypt(Label1.Caption,6474); |
ShowWindow(FindWindow(nil,'Program Manager'),SW_HIDE); |
Desktopicons zeigen
ShowWindow(FindWindow(nil,'Program Manager'),SW_SHOW); |
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0); |
Monitor einschalten
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1); |
Strg+Alt+Entf / Alt+TAB / Strg+ESC verhindern
VAR OldValue:Longbool; SystemParametersInfo(97,Word(True),@OldValue,0); //STRG+ALT+ENTF deaktiviert SystemParametersInfo(97,Word(False),@OldValue,0); //STRG+ALT+ENTF aktiviert |
with MyForm do
SetWindowPos(Handle,HWND_TOPMOST,Left,Top,Width,Height,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
|
Daten in die Registry schreiben
procedure TForm1.Button1Click(Sender:TObject);
var
reg:TRegistry;
begin
reg:=TRegistry.Create;
reg.RootKey:=hkey_local_machine;
reg.OpenKey('Software\jobo',true);
reg.WriteString('Test','Test');
reg.CloseKey;
end;
|
Daten aus der Registry lesen
Var
Registr : TRegistry;
Registr:=TRegistry.Create;
Registr.RootKey:=HKEY_LOCAL_MACHINE;
Registr.OpenKey('SOFTWARE\JOBO\test',False);
Label1.caption :=Registr.ReadString('test');
Registr.Free;
|
Eine andere Möglichkeit einen String zu verschlüsseln
Optional sollte der Schlüssel manuell eingegeben werden
const schluessel='X12GV7a'; // nur als Beispiel var sss:string; function verschl(st,schl:string):string; var x,y,lg:integer; begin if length(st)>0 then begin y:=1; lg:=length(schl); for x:=1 to length(st) do begin st[x]:=chr(ord(st[x]) xor ord(schl[y])); if y=lg then y:=1 else inc(y); end; end; result:=st; end; procedure TForm2.Button2Click(Sender: TObject); begin sss:=verschl(edit1.text,schluessel); edit1.text:=''; showmessage(sss); end; procedure TForm2.Button3Click(Sender: TObject); begin edit1.text:=verschl(sss,schluessel); end; |
Folgende Befehle aus dem Shutdownmenü sind aufrufbar
ExitWindowsEx(EWX_SHUTDOWN,0); //Windows beenden ExitWindowsEx(EWX_REBOOT,0); //Windows neu starten ExitWindowsEx(EWX_SHUTDOWN,0); //Standby Modus ExitWindowsEx(EWX_LOGOFF,0); //Neuanmelden |
Um beispielsweise eine DOS-Datei mit den richtigen Sonderzeichen auslesen zu können ist diese Funktion sehr hilfreich
type wie=(AsciiToAnsi,AnsiToAscii);
function wandlung(quelle:string;art:wie):string;
begin
SetLength(Result,Length(quelle));
if Length(Result) > 0 then
if art=AsciiToAnsi
then OemToChar(Pchar(quelle),Pchar(Result))
else
CharToOem(Pchar(quelle),Pchar(Result))
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
showmessage(wandlung('Ž™š„”á',AsciiToAnsi));
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
showmessage(wandlung('ÄÖÜäöüß',AnsiToAscii));
end;
|
Folgende Prozedur muss in CreateForm eingefügt werden um eine weitere Instanz zu unterbinden
CreateMutex(nil,FALSE,'AnyNameHere');
IF GetLastError = ERROR_ALREADY_EXISTS THEN
begin
MessageDlg('Es läuft bereits eine Instanz dieses Programms. Beenden sie es.',
mterror,[mbOK], 0);
Halt(0);
end;
Application.Initialize;
|
Mit folgender Funktion lässt sich der Benutzername herausfinden. Natürlich ist dies auch über die Registry unter HKEY_CURRENT USER möglich
function GetUserName : String; var pcUser : PChar; dwUSize : DWORD; begin dwUSize := 21; GetMem( pcUser, dwUSize ); try if Windows.GetUserName( pcUser, dwUSize ) then Result := pcUser finally FreeMem( pcUser ); end; end; Label1.Caption:=GetUserName; |
So gehts ebenfalls
var Nombre : array [0..MAX_COMPUTERNAME_LENGTH + 1] of char; Largo : DWord; begin Largo:=MAX_COMPUTERNAME_LENGTH + 1; GetUserName(Nombre,Largo); Label1.Caption:=String(Nombre); end; |
Mit dieser Funktion lässt sich der Computername herausfinden. Ebenfalls in der Registry hinterlegt
function GetComputerName : String;
var
pcComputer : PChar;
dwCSize : DWORD;
begin
dwCSize := MAX_COMPUTERNAME_LENGTH + 1;
GetMem( pcComputer, dwCSize );
try
if Windows.GetComputerName( pcComputer, dwCSize ) then
Result := pcComputer;
finally
FreeMem( pcComputer );
end;
end;
Label2.Caption:=GetComputerName; |
Einige Informationen über das eigene System erfahren (freier Speicher,...)
procedure TForm1.Button1Click(Sender: TObject);
var
MemoryStatus: TMemoryStatus;
begin
Memo1.Lines.Clear;
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
with MemoryStatus do
begin
Memo1.Lines.Add(IntToStr(dwLength) + ' Size of ''MemoryStatus'' record');
Memo1.Lines.Add(IntToStr(dwMemoryLoad) + '% memory in use');
Memo1.Lines.Add(IntToStr(dwTotalPhys) + ' Total Physical Memory in bytes');
Memo1.Lines.Add(IntToStr(dwAvailPhys) + ' Available Physical Memory in bytes');
Memo1.Lines.Add(IntToStr(dwTotalPageFile) + ' Total Bytes of Paging File');
Memo1.Lines.Add(IntToStr(dwAvailPageFile) + ' Available bytes in paging file');
Memo1.Lines.Add(IntToStr(dwTotalVirtual) + ' User Bytes of Address space');
Memo1.Lines.Add(IntToStr(dwAvailVirtual) + ' Available User bytes of address space');
end;
end;
|
Einige Informationen über ein Laufwerk erfahren
function LibreEnDisco( const Drive : Char ) : LongInt;
var
lpRootPathName : PChar;
lpSectorsPerCluster : DWORD;
lpBytesPerSector : DWORD;
lpNumberOfFreeClusters : DWORD;
lpTotalNumberOfClusters : DWORD;
begin
lpRootPathName := PChar( Drive + ':\' );
if Windows.GetDiskFreeSpace( lpRootPathName,
lpSectorsPerCluster,
lpBytesPerSector,
lpNumberOfFreeClusters,
lpTotalNumberOfClusters ) then
Result := lpNumberOfFreeClusters * lpBytesPerSector * lpSectorsPerCluster
else
Result := -1;
end;
Label1.Caption:=IntToStr( LibreEnDisco('c') );
|
Einige Informationen über ein Laufwerk erfahren
function TipoDeDisco(RaizDisco: string): string;
var
i: word;
begin
i := GetDriveType(PChar(LowerCase(RaizDisco)));
case i of
{ Unknown }
0: result := 'no puedo determinarlo';
{ it doesn't exist }
1: result := 'no existe';
{ Floppy }
DRIVE_REMOVABLE: result := 'floppy/extraible';
{ Fixed }
DRIVE_FIXED: result := 'disco fijo';
{ Net unit }
DRIVE_REMOTE: result := 'unidad de red';
{ CD-ROM }
DRIVE_CDROM: result := 'cd-rom';
{ Ram Drive }
DRIVE_RAMDISK: result := 'disco-ram';
end;
end;
Label1.Caption:=TipoDeDisco('a:\');
|
Die Laufwerkskennung des ersten CD-ROMs in Erfahrung bringen
function FindFirstCDROMDrive: Char;
var
DriveMap,
Mask: DWord;
i: Integer;
Root: String;
begin
Result := #0;
Root := 'A:\';
DriveMap := GetLogicalDrives;
Mask := 1;
for i := 1 to 32 do begin
if (Mask AND DriveMap) <> 0 then
if GetDriveType(PChar(Root)) = DRIVE_CDROM then begin
Result := Root[1];
Break;
end;
Mask := Mask shl 1;
Inc(Root[1]);
end;
end;
|
Den Windows Error-Beep (de)aktivieren
SystemParametersInfo(SPI_SETBEEP,0,NIL,SPIF_SENDWININICHANGE);//deaktiviert SystemParametersInfo(SPI_SETBEEP,1,NIL,SPIF_SENDWININICHANGE);// aktiviert |
Im Bios rumpfuschen - aus Sicherheitsgründen nicht getestet
procedure TForm1.Button1Click(Sender: TObject);
procedure EscribePuerto(Direccion:word;valor:byte);
begin
asm
mov dx,Direccion
mov AL,valor
out DX,AL
end;
end;
function LeePuerto(Direccion:Word):Byte;
begin
asm
mov dx,Direccion
in al,dx
mov Result,al
end;
end;
var
Dir:integer;
Leido:byte;
begin
ListBox1.Clear;
for Dir:=0 to 255 do
begin
EscribePuerto(StrToInt('$70'),Dir);
Sleep(1);
Leido:=LeePuerto(StrToInt('$71'));
ListBox1.Items.add(IntToStr(Leido));
Sleep(1);
Application.ProcessMessages;
end;
end;
|
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin Canclose:=false; end; |
Den Aktuellen Programmpfad finden
Path := ExtractPathFile(ParamStr(0)); |
Den Vollbildmodus absturzsicher machen, auch wenn eine MessageBox angezeigt wird
Vorher muss die Integrierte Fehlersuche ausgeschaltet werden (Menü 'Tools' - 'Debugger-Optionen' - 'Integrierte Fehlersuche')
unit main;
...
begin
TRY
...
MySwitchToFullscreen; //Vollbildmodus
//allen Fullscreencode hier!
...
EXCEPT
on E:Exception do begin
MySwitchToWindowed; //zurück in den Fenstermodus
ShowMessage('Exception in MyProg'#10#13'Message: '+E.Message); //Exception ausgeben
end;
END;
end.
|
Einen Druck auf Button1 und das loslassen nach einer 1/4 Sekunde simulieren
Button1.Perform(WM_LButtonDown,0,0); Sleep(250); Button1.Perform(WM_LButtonUp,0,0); |
Desktop-Icon-Text transparent machen - wird beim nächsten Neustart wieder neutralisiert
uses Commctrl;
var
hLV : THandle;
procedure TForm1.GetDesktopListViewHandle;
var
s1: string;
begin
hLV := FindWindow('ProgMan', nil);
hLV := GetWindow(hLV, GW_CHILD);
hLV := GetWindow(hLV, GW_CHILD);
SetLength(s1, 40);
GetClassName(hLV, PChar(s1), 39);
if PChar(s1) <> 'SysListView32' then
ShowMessage('Failed');
end;
procedure TForm1.Button1Click(Sender: TObject);
var
xColor : TColor;
begin
GetDesktopListViewHandle;
xColor := ListView_GetTextColor(hLV);
ListView_SetTextColor(hLV, xColor);
xColor := ListView_GetTextBkColor(hLV);
ListView_SetTextBkColor(hLV, xColor);
ListView_SetTextBkColor(hLV, $FFFFFFFF);
end;
|
Während rechenintensiver Proceduren verbraucht
das Programm sämtliche Systemresourcen, die sogar das bewegen von Fenstern
nicht mehr erlauben. Um ihm ein wenig Verschnaufzeit zu gönnen fügt man den
Befehl "Application.ProcessMessages" ein.
Beispiel:
For g := 1 to 2000000 do begin a := Sin( g ) + a; Application.ProcessMessages; end; |
Position eines fremden Fensters verändern
WinHandle := FindWindow( nil, 'Arbeitsplatz' ); If WinHandle > 0 then begin SetWindowPos( WinHandle, HWND_TOP, 10, 10, 310, 210, SWP_SHOWWINDOW ); SetWindowText( WinHandle, 'Mein Computer' ); end; |