World of JOBO - Delphi

www.jobo2000.de - delphi

Home - Delphi - Video - Art - Render - Texte - Spiele - Download - Links - Mail

Tipps:

Texte:

Designing Computer Games

2D vs. 3D: Fight of the Century

Puzzledesign

Grundlagen der KI

Erweiterte KI

System:
Desktop-Icons verstecken	Windows herunterfahren
Eigene Cursor verwenden	ASCII-Zeichen in ANSI-Zeichen umwandeln
Mit der Registry arbeiten	Nur eine Instanz eines Programms erlauben
Bilder in die Zwischenablage kopieren	Benutzername herausfinden
Ein Programm Stayontop machen	Computername herausfinden
CD-Rom öffnen/schließen	Systeminfos abfragen
Das Windowsverzeichnis erfahren	Laufwerkinfos abfragen
Einen String Ver-und Entschlüsseln	Laufwerktyp erfahren
Ein anderes Verschlüssel-Beispiel	Laufwerkskennung des ersten CD-ROMs
Den Taskbareintrag verstecken	Windows Error-Beep (de)aktivieren
Den Taskmanagereintrag verstecken	Im Bios rumpfuschen
Monitor ein/ausschalten	ALT+F4 verhindern
Strg+Alt+Entf (de)aktivieren	Den Aktuellen Programmpfad finden
Vollbildmodus absturzsicher	Klick auf TButton simulieren
Desktop-Icon-Text transparent	Ein Programm "rezessiv" machen
Position eines fremden Fensters verändern

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

Das Windowsverzeichnis finden

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;

Den Taskbareintrag verstecken

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;

Einen String verschlüsseln

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

Desktopicons verstecken

ShowWindow(FindWindow(nil,'Program Manager'),SW_HIDE);

Desktopicons zeigen

ShowWindow(FindWindow(nil,'Program Manager'),SW_SHOW);

Monitor ausschalten

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

Das Formular Stayontop machen

 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;

ALT+F4 vereiteln

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;

Hosted by www.Geocities.ws