XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Laufwerk- und System-Infos abfragen
######################################
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#,5
    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
-------------------------<