{ -------------------------------------------------------------------- }
{ Dieser Quelltext ist urheberrechtlich geschuetzt.                    }
{ (c) 2000-2001 OpenXP-Team & Claus Faerber                            }
{ (c) 2002-2024 FreeXP, http://www.freexp.de                           }
{ CrossPoint ist eine eingetragene Marke von Peter Mandrella.          }
{                                                                      }
{ Die Nutzungsbedingungen fuer diesen Quelltext finden Sie in der      }
{ Datei SLIZENZ.TXT oder auf http://www.crosspoint.de/oldlicense.html  }
{ -------------------------------------------------------------------- }

{$R xp_ntvdm.rc       }

Library xp_ntvdm;

uses windows,dos,strings,registry;

const xp_ntvdm_version=$6;

{ --- Imports from ntvdm.exe ------------------------------------        }

  procedure setEAX(para:ULONG);  external 'ntvdm.exe';   { function getEAX:ULONG; external 'ntvdm.exe';        }
{ procedure setAX(para:USHORT);  external 'ntvdm.exe';        } { function getAX:USHORT; external 'ntvdm.exe';        }
{ procedure setAL(para:UCHAR);   external 'ntvdm.exe';        } { function getAL:UCHAR;  external 'ntvdm.exe';        }
{ procedure setAH(para:UCHAR);   external 'ntvdm.exe';        } { function getAH:UCHAR;  external 'ntvdm.exe';        }

{ procedure setEBX(para:ULONG);  external 'ntvdm.exe';        } { function getEBX:ULONG; external 'ntvdm.exe';        }
{ procedure setBX(para:USHORT);  external 'ntvdm.exe';        } { function getBX:USHORT; external 'ntvdm.exe';        }
{ procedure setBL(para:UCHAR);   external 'ntvdm.exe';        } { function getBL:UCHAR;  external 'ntvdm.exe';        }
{ procedure setBH(para:UCHAR);   external 'ntvdm.exe';        } { function getBH:UCHAR;  external 'ntvdm.exe';        }

{ procedure setECX(para:ULONG);  external 'ntvdm.exe';        }   function getECX:ULONG; external 'ntvdm.exe';  
{ procedure setCX(para:USHORT);  external 'ntvdm.exe';        } { function getCX:USHORT; external 'ntvdm.exe';        }
{ procedure setCL(para:UCHAR);   external 'ntvdm.exe';        }   function getCL:UCHAR;  external 'ntvdm.exe';  
{ procedure setCH(para:UCHAR);   external 'ntvdm.exe';        }   function getCH:UCHAR;  external 'ntvdm.exe';  

{ procedure setEDX(para:ULONG);  external 'ntvdm.exe';        } { function getEDX:ULONG; external 'ntvdm.exe';        }
{ procedure setDX(para:USHORT);  external 'ntvdm.exe';        }   function getDX:USHORT; external 'ntvdm.exe';  
{ procedure setDH(para:UCHAR);   external 'ntvdm.exe';        } { function getDH:UCHAR;  external 'ntvdm.exe';        }
{ procedure setDL(para:UCHAR);   external 'ntvdm.exe';        } { function getDL:UCHAR;  external 'ntvdm.exe';        }

{ procedure setESP(para:ULONG);  external 'ntvdm.exe';        } { function getESP:ULONG; external 'ntvdm.exe';        }
{ procedure setSP(para:USHORT);  external 'ntvdm.exe';        } { function getSP:USHORT; external 'ntvdm.exe';        }

{ procedure setEBP(para:ULONG);  external 'ntvdm.exe';        } { function getEBP:ULONG; external 'ntvdm.exe';        }
{ procedure setBP(para:USHORT);  external 'ntvdm.exe';        } { function getBP:USHORT; external 'ntvdm.exe';        }

{ procedure setESI(para:ULONG);  external 'ntvdm.exe';        }   function getESI:ULONG; external 'ntvdm.exe';  
{ procedure setSI(para:USHORT);  external 'ntvdm.exe';        } { function getSI:USHORT; external 'ntvdm.exe';        }

{ procedure setEDI(para:ULONG);  external 'ntvdm.exe';        }   function getEDI:ULONG; external 'ntvdm.exe';  
{ procedure setDI(para:USHORT);  external 'ntvdm.exe';        } { function getDI:USHORT; external 'ntvdm.exe';        }

{ procedure setEIP(para:ULONG);  external 'ntvdm.exe';        } { function getEIP:ULONG; external 'ntvdm.exe';        }
{ procedure setIP(para:USHORT);  external 'ntvdm.exe';        } { function getIP:USHORT; external 'ntvdm.exe';        }

{ procedure setCS(para:USHORT);  external 'ntvdm.exe';        } { function getCS:USHORT; external 'ntvdm.exe';        }
{ procedure setSS(para:USHORT);  external 'ntvdm.exe';        } { function getSS:USHORT; external 'ntvdm.exe';        }
{ procedure setDS(para:USHORT);  external 'ntvdm.exe';        } { function getDS:USHORT; external 'ntvdm.exe';        }
{ procedure setES(para:USHORT);  external 'ntvdm.exe';        } { function getES:USHORT; external 'ntvdm.exe';        }
{ procedure setFS(para:USHORT);  external 'ntvdm.exe';        } { function getFS:USHORT; external 'ntvdm.exe';        }
{ procedure setGS(para:USHORT);  external 'ntvdm.exe';        } { function getGS:USHORT; external 'ntvdm.exe';        }

  procedure setCF(para:ULONG);   external 'ntvdm.exe';   { function getCF:ULONG;  external 'ntvdm.exe';        }
{ procedure setPF(para:ULONG);   external 'ntvdm.exe';        } { function getPF:ULONG;  external 'ntvdm.exe';        }
{ procedure setAF(para:ULONG);   external 'ntvdm.exe';        } { function getAF:ULONG;  external 'ntvdm.exe';        }
{ procedure setZF(para:ULONG);   external 'ntvdm.exe';        } { function getZF:ULONG;  external 'ntvdm.exe';        }
{ procedure setSF(para:ULONG);   external 'ntvdm.exe';        } { function getSF:ULONG;  external 'ntvdm.exe';        }
{ procedure setIF(para:ULONG);   external 'ntvdm.exe';        } { function getIF:ULONG;  external 'ntvdm.exe';        }

{ procedure setDF(para:ULONG);   external 'ntvdm.exe';         }
{ procedure setOF(para:ULONG);   external 'ntvdm.exe';         }
{ procedure setMSW(para:USHORT); external 'ntvdm.exe';         }

function  GetVDMAddress(Address,Size:ULONG; ProtectedMode:BOOL):Pointer; external 'ntvdm.exe' name 'MGetVdmPointer';
function  FreeVDMPointer(Address:ULONG; Size:USHORT; Buffer:Pointer; ProtectedMode:BOOL):BOOL; begin FreeVDMPointer := true; end;

    procedure RtlGetNtVersionNumbers(var MajorVersion : DWORD;
                                     var MinorVersion : DWORD;
                                     var Build        : DWORD);
              stdcall; external 'ntdll.dll';

{ --- Exact Windows Version -------------------------------------        }

procedure get_windows_version;
var
      MajorVersion   : DWORD;
      MinorVersion   : DWORD;
      BuildNumberRec : packed record
                         BuildNumber : word;
                         Build       : word;
                       end;
      Build          : DWORD absolute BuildNumberRec;
      version: DWORD;

begin  
  {setEAX(GetVersion);       }
  RtlGetNtVersionNumbers(MajorVersion, MinorVersion, Build);
  VERSION:=MajorVersion+(MinorVersion*256)+(BuildNumberRec.BuildNumber*256*256);
  setEAX(VERSION);
end;

{ --- Clipboard functions ---------------------------------------        }

procedure getWinProductName;
var maxlen:   integer;
    len:      integer;
    i:	      integer;
    sp:       ^shortstring;
    Registry: TRegistry;
    ProductName: shortstring;
begin
  maxlen := getCL;
  sp := GetVDMAddress(GetEDI,maxlen,false);
  Registry := TRegistry.Create;
  Registry.RootKey := HKEY_LOCAL_MACHINE;
  if Registry.OpenKeyReadOnly('\SOFTWARE\Microsoft\Windows NT\CurrentVersion') then
     ProductName:=Registry.ReadString('ProductName'); 
  sp^:=ProductName;
  Registry.Free;
  FreeVDMPointer(GetEDI,maxlen,sp,false);
end;

procedure clip_to_string;
var maxlen:  integer;
    len:     integer;
    i:	     integer;
    oneline: boolean;
    sp:      ^shortstring;
    ch:	     HANDLE;
    cp:	     PChar;
begin
  maxlen := getCL;
  oneline:= getCH<>0;
  sp := GetVDMAddress(GetEDI,maxlen,false);
  setCF(1);

  OpenClipboard(0);
  ch := GetClipboardData(CF_OEMTEXT); 
  if ch<> 0 then
  begin
    cp := GlobalLock(ch); 
    if cp <> nil then
    begin
      len := StrLen(cp);
      if len>255    then len:=255; 
      if len>maxlen then len:=maxlen;
      MoveMemory(PChar(Pointer(sp))+1,cp,len);
      sp^[0]:=Char(Byte(len));
    end;
    if oneline then 
      for i:=1 to len do
        if sp^[i]<#32 then
          sp^[i]:=#32;
    setCF(0);	  
    
    GlobalUnlock(ch);
  end;
  CloseClipboard;

  FreeVDMPointer(GetEDI,maxlen,sp,false);
end;

procedure mem_to_clip;
var 	cp: PChar;
	cl: ULONG;
	hm: HANDLE;
	pm: PChar;
begin
  cl := GetECX;
  cp := GetVDMAddress(GetESI,cl,false);

  SetCF(1);

  if OpenClipboard(0) then 
  begin
    hm := GlobalAlloc(GMEM_MOVEABLE,cl+1);
    if hm <> 0 then
    begin
      pm := GlobalLock(hm);
      if pm <> nil then
      begin
        MoveMemory(pm,cp,cl);
        (PChar(pm)+cl)^ := #0;
	GlobalUnLock(hm);

	EmptyClipboard;
        SetClipboardData(CF_OEMTEXT,hm);
	SetCF(0);
      end;
    end;
    CloseClipboard;
  end;
  
  FreeVDMPointer(GetESI,cl,cp,false);
end;

procedure clip_to_file;
var	fn: PChar;
	fh: Handle;
	ch: Handle;
	cp: LPTSTR;
	wr: DWORD;
begin
  fn:=GetVDMAddress(GetESI,$10000,false);
  setCF(1);

  OpenClipboard(0);
  ch := GetClipboardData(CF_OEMTEXT); 
  if ch<> 0 then
  begin
    cp := GlobalLock(ch); 
    if cp <> nil then
    begin
      fh:=CreateFile(fn,GENERIC_WRITE,0,0,CREATE_ALWAYS,
        FILE_FLAG_SEQUENTIAL_SCAN,0);
      if fh<>INVALID_HANDLE_VALUE then 
      begin
        WriteFile(fh,cp^,StrLen(cp),wr,0);
	CloseHandle(fh);
	setCF(0);
      end;
      GlobalUnlock(ch); 
    end;
  end;
  CloseClipboard;

  FreeVDMPointer(GetESI,0,fn,false);
end;

procedure file_to_clip;
var	fn: PChar;
	fh: Handle;
	ln: DWORD;
	mh: HANDLE;
	mp: PChar;
begin
  fn:=GetVDMAddress(GetESI,$10000,false);
  setCF(1);

  fh:=CreateFile(fn,GENERIC_READ,0,0,OPEN_EXISTING,
    FILE_FLAG_SEQUENTIAL_SCAN,0);
  if fh<>INVALID_HANDLE_VALUE then 
  begin
    ln := GetFileSize(fh,nil);
    mh := GlobalAlloc(GMEM_MOVEABLE,ln+1);
    if mh <> 0 then 
    begin
      mp := GlobalLock(mh);
      if mp <> nil then
      begin
        ReadFile(fh,mp^,ln,ln,nil);
        (PChar(mp)+ln)^ := #0;
	GlobalUnlock(mh);
        
	if OpenClipboard(0) then 
	begin
	  EmptyClipboard;
  	  SetClipboardData(CF_OEMTEXT,mh);
          CloseClipboard;
	end;
        setCF(0);
      end else
        GlobalFree(mh);
    CloseHandle(fh);
    end;
  end;

  FreeVDMPointer(GetESI,0,fn,false);
end;

{ --- Calls for DiskFree/DiskSize -------------------------------        }
procedure NTDiskFree;
var a:longint;
    b:integer; 
begin
  b:=GetCL;
  a:=(DiskFree(b) DIV 1048576);
  SetEAX(a); 
end;

procedure NTDiskSize;
var a:longint;
    b:integer;
begin
  b:=GetCL;
  a:=(DiskSize(b) DIV 1048576);
  SetEAX(a);
end;

{ --- NTDiskType ------------------------------------------------        }
procedure NTDiskType;
var p :pchar;
begin
  p:=Stralloc(4);
  StrPCopy(p,chr(GetCL+64)+':\');
  SetEAX(GetDriveTypeA(p));
end;

{ --- XP_NTVDM_VER ----------------------------------------------        }
procedure XP_NTVDM_VER;
begin
  SetEAX(xp_ntvdm_version);
end;

{ --- ConsoleTitle ----------------------------------------------        }
procedure NTGetConsoleTitle;
var sp       : ^shortstring;
    contitlea: array [0..255] of Char;
    contitle : PChar;
    contsize : DWORD;
    maxlen   : integer;
begin
  maxlen := getCL;
  sp := GetVDMAddress(GetEDI,maxlen,false);
  contsize:=maxlen;
  contitle:=@contitlea;
  contsize:=GetConsoleTitle(contitle,contsize);
  sp^:=StrPas(contitle);
end;

procedure NTGetConsoleTitleW;
var sp      : LPWSTR;
    maxlen  : longint;
begin
  maxlen := getECX;
  sp := GetVDMAddress(GetEDI,maxlen,false);
  GetConsoleTitleW(sp,maxlen);
end;

procedure NTSetConsoleTitle;
var sp       : ^shortstring;
    contitlea: array [0..255] of Char;
    contitle : PChar;
    maxlen   : integer;
begin
  maxlen := getCL;
  sp := GetVDMAddress(GetEDI,maxlen,false);
  contitle:=@contitlea;
  StrPCopy(contitle,sp^);
  contitle:=@contitlea;
  SetConsoleTitle(contitle);
end;

procedure NTSetConsoleTitleW;
var sp      : LPCWSTR;
    maxlen  : longint;
begin
  maxlen := getECX;
  sp := GetVDMAddress(GetEDI,maxlen,false);
  SetConsoleTitleW(sp);
end;

{ --- GetTimeZone ----------------------------------------------        }

procedure GetTimeZone1;
var TZ : TTimeZoneInformation;
    mode: integer;
begin
  mode:=0;
  case GetTimeZoneInformation(TZ) of
    TIME_ZONE_ID_UNKNOWN :
      begin
        mode:=0;
      end;
    TIME_ZONE_ID_STANDARD:
      begin
        mode:=0;
      end;
    TIME_ZONE_ID_DAYLIGHT:
      begin
        mode:=1;
      end;
  end;
  setEAX(mode);
end;

procedure GetTimeZone2;
var TZ : TTimeZoneInformation;
    minutes : integer;
begin
  minutes:=0;
  case GetTimeZoneInformation(TZ) of
    TIME_ZONE_ID_UNKNOWN :
      begin
        minutes:=TZ.Bias;
      end;
    TIME_ZONE_ID_STANDARD:
      begin
        minutes:=TZ.Bias + TZ.StandardBias;
      end;
    TIME_ZONE_ID_DAYLIGHT:
      begin
        minutes:=TZ.Bias + TZ.DaylightBias;
      end;
  end;
  setEAX(minutes);
end;

procedure Is64BitWindows;
{$IFDEF WIN32       }
type
  TIsWow64Process = function(Handle: Windows.THandle; var Res: Windows.BOOL): Windows.BOOL; stdcall;
var
  IsWOW64: Windows.BOOL;
  IsWOW64Process: TIsWow64Process;
{$ENDIF       }
begin
{$IFDEF WIN32       }
  // Try to load required function from kernel32
  IsWOW64Process := TIsWow64Process(Windows.GetProcAddress(Windows.GetModuleHandle('kernel32'), 'IsWow64Process'));
  if Assigned(IsWOW64Process) then
    begin
      // Function exists
      if not IsWOW64Process(Windows.GetCurrentProcess, IsWOW64) then
        setEAX(0)
      else if IsWOW64 then
		setEAX(1)
	  else
        setEAX(0);
    end
  else
    // Function not implemented: can't be running on Wow64
    setEAX(0);
{$ELSE       } //if were running 64bit code, OS must be 64bit :)
   setEAX(1);
{$ENDIF       }
end;



{ --- VDD calls -------------------------------------------------        }

procedure FREEXP_CALL; stdcall; export;
begin
  case getDX of
    {Versionsinfos       }
    $0000: get_windows_version;    {Windows NT Version bestimmen       }
    $0001: XP_NTVDM_VER;           {Revision der XP_NTVDM.DLL bestimmen       }
    $0002: GetTimeZone1;           {Timezone aus Windows 2000/XP/Server 2003/7 (nur XPM) bestimmen       }
    $0003: GetTimeZone2;           {Timezone aus Windows 2000/XP/Server 2003/7 (nur XPM) bestimmen       }
    $0004: Is64BitWindows;         {Windows x64?       }
    $0005: getWinProductName;      {Windows Produktnamen auslesen       }

    {Clipboardfunktionen       }
    $0101: clip_to_string;         {einen String aus der Zwischenablage lesen       }
    $0102: mem_to_clip;            {einen Speicherbereich in die Zwischenablage speichern       }
    $0103: clip_to_file;           {den Inhalt der Zwischenablage in eine Datei speichern       }
    $0104: file_to_clip;           {eine Datei in die Zwischenablage speichern       } 

    {Datentraegerfunktionen       }
    $0200: NTDiskFree;             {Den freien Speicherplatz auf dem Datentr ger bestimmen       }
    $0201: NTDiskSize;             {Die Gesamtgr  e des Datentr gers bestimmen       }
    $0203: NTDiskType;             {Art eines Datentr gers bestimmen       }

    {ConsoleTitle       }
    $0300: NTGetConsoleTitle;      {Consolentitle in FreeXP einlesen (ASCII)       }
    $0301: NTGetConsoleTitleW;     {Consolentitle in FreeXP einlesen (UTF)       }
    $0302: NTSetConsoleTitle;      {Consolentitle mit FreeXP neu setzen (ASCII)       }
    $0303: NTSetConsoleTitleW;     {Consolentitle mit FreeXP neu setzen (UTF)       }
  end;
end;  

procedure FREEXP_INIT; stdcall; export;
begin
end;

{ --- DLL exports -----------------------------------------------        }

exports FREEXP_INIT;
exports FREEXP_CALL;

end.

{
 
       }  
