'######################################
'Short-System-Info
'######################################
'System-Informationen abfragen
'ab Profan 7.X
'Andreas Miethe Dezember 2000
'######################################
'
'--------------------------------------
'Funktionen ( WIN-API )
'--------------------------------------
DEF GetVersionEx(1) ! "Kernel32","GetVersionExA"
DEF GlobalMemoryStatus(1) ! "Kernel32","GlobalMemoryStatus"
DEF GetDiskFreeSpace(5) ! "Kernel32","GetDiskFreeSpaceA"
DEF GetDiskFreeSpaceEx(4) !"KERNEL32","GetDiskFreeSpaceExA"
DEf GetLogicalDriveStrings(2) ! "KERNEL32","GetLogicalDriveStringsA"
Def GetDriveType(1) ! "KERNEL32","GetDriveTypeA"
Def GetVolumeInformation(8) ! "Kernel32.dll","GetVolumeInformationA"
Def GetStockObject(1) !"GDI32","GetStockObject"
Def SetDefaultGUIFont(1) SendMessage(&(1),$30,Val(GetStockObject($11)),1)
DEF SetWindowlong(3) ! "User32","SetWindowLongA"
DEF @GSFP(4) ! "Shell32","SHGetSpecialFolderPathA"
DEF @GTP(2) ! "Kernel32","GetTempPathA"
DEF GetWindowlong(2) ! "User32","GetWindowLongA"
DEf LockWindowUpdate(1) ! "USER32","LockWindowUpdate"
DEf GetColor(1) ! "User32","GetSysColor"
'--------------------------------------
'Konstanten
'--------------------------------------
DEf &Ver_Platform_Win32_Windows 1
DEf &Ver_Platform_Win32_NT 2
'--------------------------------------
'
'--------------------------------------
'Strukturen
'--------------------------------------
Struct OSVERSIONINFO = dwOSVersionInfoSize&,dwMajorVersion&,dwMinorVersion&,\
                       dwBuildNumber&,dwPlatformId&,szCSDVersion$(128)
Struct MEMORYSTATUS  = dwLenght&,dwMemoryLaod&,dwTotalPhys&,dwAvailPhys&,\
                       dwTotalPageFile&,dwAvailPageFile&,\
                       dwTotalVirtual&,dwAvailVirtual&
Struct LW            = LWString$(104)
Struct RootString    = ROOT$(4)
Struct VolumeName    = VN$(260)
Struct FileSystemBuf = FS$(260)
Struct PfadInfo      = PfadInf$(260)
'--------------------------------------
'
'--------------------------------------
'Globale Variablen und private Definitionen
'--------------------------------------
Declare OS#,MEM#,LW#,RS#,VN#,FS#
Declare Liste&,SystemInfo&,LaufwerksInfo&,PfadInfo&,Ende&
Declare Ende%,St$
Declare Pfad#

Usermessages $210
Def HiWord(1) Div&(&(1),$10000)
Def LoWord(1) And(&(1),$FFFF)
'--------------------------------------
'
'--------------------------------------
'Prozeduren
'--------------------------------------
Proc GetOSInfo
Declare Ret&,Winver$
Dim OS#,OSVERSIONINFO
OS#.dwOSVersionInfoSize& = 148
Ret& = GetVersionEx(OS#)
If OS#.dwPlatformId& = &Ver_Platform_Win32_Windows
        If OS#.dwMajorVersion& = 4
                Case OS#.dwMinorVersion& = 0  : Winver$ = "Windows 95"
                Case OS#.dwMinorVersion& = 10 : Winver$ = "Windows 98"
                Case OS#.dwMinorVersion& = 90 : Winver$ = "Windows ME"
        Endif
ElseIf OS#.dwPlatformId& = &Ver_Platform_Win32_NT
        Case OS#.dwMajorVersion& = 4 : Winver$ = "Windows NT 4"
        Case OS#.dwMajorVersion& = 5 : Winver$ = "Windows 2000"
Endif
Dispose OS#
Return Winver$
EndProc
'
Proc GetMemoryStatus
Decimals 2
Dim MEM#,MEMORYSTATUS
GlobalMemoryStatus(MEM#)
AddString(Liste&,"Arbeitsspeicher benutzt :" + Str$(MEM#.dwMemoryLaod&) + " %")
AddString(Liste&,"Arbeitsspeicher total : " + Format$("###,###,###.##",Str$(MEM#.dwTotalPhys&/1024)) + " KB")
AddString(Liste&,"Arbeitsspeicher verfügbar: " + Format$("###,###,###.##",Str$(MEM#.dwAvailPhys&/1024)) + " KB")
AddString(Liste&,"Virtueller Speicher total : " + Format$("###,###,###.##",Str$(MEM#.dwTotalVirtual&/1024)) + " KB")
AddString(Liste&,"Virtueller Speicher verfuegbar : " + Format$("###,###,###.##",Str$(MEM#.dwAvailVirtual&/1024)) + " KB")
Dispose MEM#
EndProc
'
Proc GetDiskSpace
Declare lw#,freiuser#,total#,frei#,Lolong&,Hilong&,loergebnis!,hiergebnis!
Declare Gesamt!,Frei!
Declare alles!
Declare RootPathName$
Declare Ret&,Ver&,Z$
Dim lw#,3
Dim frei#,8
Dim total#,8
Dim freiuser#,8

Ver& = 65
Addstring(Liste&,"")
Addstring(Liste&,"Speicherplatz :")
Whilenot Ver& = 91
RootPathName$ = CHR$(Ver&)+":\"
String lw#,0=RootPathName$
Ret& = GetDiskFreeSpaceEx(lw#,freiuser#,total#,frei#)
If ret& > 0

Let loergebnis!=Long(total#,0)
Let hiergebnis!=Long(total#,4)
case @Lt(loergebnis!,0): let loergebnis!= @Add(loergebnis!, @Pow(2,32))
Let Gesamt!= @Add(@Mul(hiergebnis!, @Pow(2,32)), loergebnis!)
Z$ = RootPathName$ + Format$("###,###,##0.##",(Gesamt!) / 1024 / 1024)
Z$ = Z$ + " MB frei  -  "

Let loergebnis!=Long(frei#,0)
Let hiergebnis!=Long(frei#,4)
case @Lt(hiergebnis!,0): let hiergebnis!= @Add(hiergebnis!, @Pow(2,32))
case @Lt(loergebnis!,0): let loergebnis!= @Add(loergebnis!, @Pow(2,32))
Let Frei!= @Add(@Mul(hiergebnis!, @Pow(2,32)), loergebnis!)
Z$ = Z$ + Format$("###,###,##0.##",(Frei!) / 1024 / 1024)
Z$ = Z$ + " MB frei  -  "

Z$ = Z$ + Format$("###,###,##0.##",(Gesamt!-Frei!) / 1024 / 1024)
Z$ = Z$ + " MB belegt"
Addstring(Liste&,z$)
alles! = alles!+frei!
Endif
Ver& = Ver& +1
EndWhile
Addstring(Liste&,Format$("Frei insgesamt : ###,###,##0.## MB",alles! / 1024 / 1024 ))
dispose lw#
EndProc
'
Proc GetVolumeInfos
Parameters ROOT$
Declare RET&,SerialNumber&,MCL&,Flag&
Dim RS#,RootString
Dim VN#,VolumeName
Dim FS#,FileSystemBuf
RS#.ROOT$ = ROOT$
RET& = GetVolumeInformation(RS#,VN#,260,Addr(Serialnumber&),Addr(MCL&),Addr(Flag&),FS#,260)
Case RET& > 0 : ST$ = ST$ + "["+String$(VN#,0)+"]",
Case RET& > 0 : ST$ = ST$ + "Seriennummer : "+ Left$(Hex$(Serialnumber&),4)+"-"+Right$(Hex$(Serialnumber&),4)
Case RET& > 0 : ST$ = ST$ + "  "+String$(FS#,0)
Case RET& = 0 : ST$ = ST$ + ""
Dispose RS#
Dispose VN#
Dispose FS#
EndProc
'
Proc GetLogicalDrives
Decimals 0
Declare LWZeichen&,Laufwerke&,LZ&,LW$
Dim LW#,LW
LWZeichen& = 104
Laufwerke& = GetLogicalDriveStrings(LWZeichen&,LW#)
Addstring(Liste&,"Installierte Laufwerke : ",+ Laufwerke& / 4)
Whilenot LZ& = Laufwerke&
ST$ = Upper$(String$(LW#,LZ&));
LW$ = String$(LW#,LZ&)
Case GetDriveType(Addr(LW$)) = 2 : ST$ = ST$ + " Wechselmedium "
Case GetDriveType(Addr(LW$)) = 3 : ST$ = ST$ + " Festplatte "
Case GetDriveType(Addr(LW$)) = 4 : ST$ = ST$ + " Netzlaufwerk "
Case GetDriveType(Addr(LW$)) = 5 : ST$ = ST$ + " CD-ROM "
Case GetDriveType(Addr(LW$)) = 6 : ST$ = ST$ + " RAM-Disk "
Case GetDriveType(Addr(LW$)) = 0 : ST$ = ST$ + " unbekannt "
GetVolumeInfos lw$
AddString(Liste&,ST$)
LZ& = LZ& + 4
EndWhile
Dispose LW#
Endproc
'
Proc Pfade
Declare x%
Dim pfad#,PfadInfo
Whilenot gt(x%,80)
        @GSFP(%hwnd,pfad#,x%,0)
        Case gt$(pfad#.PfadInf$,""):addstring(Liste&,"CSIDL "+ format$("0000",str$(x%))+" = "+String$(Pfad#,0))
        inc x%
Endwhile
@GTP(260,Pfad#)
AddString(Liste&,"")
AddString(Liste&,"Windows-Ordner : "+$WinPath)
AddString(Liste&,"System-Ordner : "+$SysPath)
AddString(Liste&,"Temp-Ordner : "+ pfad#.PfadInf$)
Dispose Pfad#
Endproc
'
Proc Aufbau
Liste& = @Create("ListBox",%HWND,"",0,0,0,0)
SetWindowLong(Liste&,-20,$200)
SetDefaultGUIFont(Liste&)
SetWindowpos Liste& = 200,20-420,400
SystemInfo& = @Create("Button",%HWND,"SystemInfos",10,20,170,48)
LaufwerksInfo& = @Create("Button",%HWND,"LaufwerksInfos",10,70,170,48)
PfadInfo& = @Create("Button",%HWND,"PfadInfos",10,120,170,48)
Ende& = @Create("Button",%HWND,"Ende",10,170,170,48)
SetDefaultGUIFont(SystemInfo&)
SetDefaultGUIFont(LaufwerksInfo&)
SetDefaultGUIFont(PfadInfo&)
SetDefaultGUIFont(Ende&)
EndProc
'--------------------------------------
'
'--------------------------------------
'Hauptprogramm
'--------------------------------------
SetTrueColor 1
WindowTitle "System-Infos..."
WindowStyle 27
Window %maxx+1,0-640,480
Cls GetColor(15)
UseIcon "A"
Aufbau
SetWindowPos %HWND = 10,10-640,480
Whilenot Ende%
Waitinput
        If AND(@GetFocus(SystemInfo&),neq(LoWord(&UWparam),513))
                LockWindowUpdate(%hwnd)
                SendMessage(Liste&,$0184,0,0)
                GetOSInfo
                AddString(Liste&,"Betriebssystem = "+ @$(0))
                AddString(Liste&,"")
                AddString(Liste&,"Speicherauslastung :")
                GetMemoryStatus
                LockWindowUpdate(0)
        ElseIf AND(@GetFocus(LaufwerksInfo&),neq(LoWord(&UWparam),513))
                LockWindowUpdate(%hwnd)
                SendMessage(Liste&,$0184,0,0)
                GetLogicalDrives
                GetDiskSpace
                LockWindowUpdate(0)
        ElseIf AND(@GetFocus(PfadInfo&),neq(LoWord(&UWparam),513))
                LockWindowUpdate(%hwnd)
                SendMessage(Liste&,$0184,0,0)
                AddString(Liste&,"Pfadinfos :")
                AddString(Liste&,"")
                Pfade
                LockWindowUpdate(0)
        ElseIf AND(@GetFocus(Ende&),neq(LoWord(&UWparam),513))
                Let Ende% = 1
        Endif
EndWhile
End
'--------------------------------------