Deutsch
Quelltexte/ Codesnippets

Frei Gigabyte Mem Ram Speicher Wmi

 
- Seite 1 -


Andreas Miethe, URL=www.rgh-soft.de/forum01/read.php?f=7&i=14703&t=14696, Zeitpunkt=20.01.2010
Proc GetMem

    Parameters v&
    Struct MEMORYSTATUSEX =
    dwLength&,
    dwMemoryLoad&,
    ullTotalPhysLow&,
    ullTotalPhysHi&,
    ullAvailPhysLow&,
    ullAvailPhysHi&,
    ullTotalPageFileLow&,
    ullTotalPageFileHi&,
    ullAvailPageFileLow&,
    ullAvailPageFileHi&,
    ullTotalVirtualLow&,
    ullTotalVirtualHi&,
    ullAvailVirtualLow&,
    ullAvailVirtualHi&,
    ullAvailExtendedVirtualLow&,
    ullAvailExtendedVirtualHi&
    Declare Memory#
    Dim Memory#,MEMORYSTATUSEX
    Memory#.dwLength& = SizeOf(Memory#)
    External("Kernel32.dll","GlobalMemoryStatusEx",Memory#)
    Declare TotalMem!
    Declare TotalMem1!

    If V& = 1

        Totalmem! = Memory#.ullTotalPhysLow&
        case Memory#.ullTotalPhysLow& < 0: TotalMem! =  Memory#.ullTotalPhysLow& + (2^32)
        TotalMem! = (Memory#.ullTotalPhysHi& * (2^32)) + TotalMem!
        Dispose Memory#
        Return Format$("nutzbarer physikalischer Speicher : ##,###.#0 MB",Totalmem!/1024^2)

    elseif V& = 2

        Totalmem! = Memory#.ullAvailPhysLow&
        case Memory#.ullAvailPhysLow& < 0: TotalMem! =  Memory#.ullAvailPhysLow& + (2^32)
        TotalMem! = (Memory#.ullAvailPhysHi& * (2^32)) + TotalMem!
        Dispose Memory#
        Return Format$("zur Verfügung stehender Speicher  : ##,###.#0 MB",Totalmem!/1024^2)

    elseif V& = 3

        Totalmem! = Memory#.ullTotalPhysLow&
        case Memory#.ullTotalPhysLow& < 0: TotalMem! =  Memory#.ullTotalPhysLow& + (2^32)
        TotalMem! = (Memory#.ullTotalPhysHi& * (2^32)) + TotalMem!
        Totalmem1! = Memory#.ullAvailPhysLow&
        case Memory#.ullAvailPhysLow& < 0: TotalMem1! =  Memory#.ullAvailPhysLow& + (2^32)
        TotalMem1! = (Memory#.ullAvailPhysHi& * (2^32)) + TotalMem1!
        Dispose Memory#
        Return Format$("Belegter Speicher                 : ##,###.#0 MB",(Totalmem!-Totalmem1!)/1024^2)

    elseif V& = 4

        Totalmem! = Memory#.dwMemoryload&
        Dispose Memory#
        Return Format$("Belegter Speicher                 : ###.## %",TotalMem!)

    Endif

EndProc

CLS
Print GetMem(1)
Print GetMem(2)
Print GetMem(3)
Print GetMem(4)
Waitinput
 
20.01.2010  
 



 
- Seite 1 -



E.T.
Feine Sache, aber Programm "bescheißt" :



Der tatsächlich eingebaute Speicher wäre auch noch interessant,
XP verrät das auch immer nicht

13 kB
Hochgeladen:21.01.2010
Ladeanzahl147
Herunterladen
 
Grüße aus Sachsen... Mario WinXP, Win7 (64 Bit),Win8(.1), Profan 6 - X4, XPSE, und 'nen schwarzes, blinkendes Dingens, wo ich das alles reinschütte...
Guggst du hier:  [...] 
Aussichten:  [...] 
21.01.2010  
 



Arbeitsplatz rechte Maustaste Eigenschaften - steht es auch nicht? Spätestens wohl per WMI abfragbar - vielleicht könnte Roland für WMI eine Stittschnelle bereitstellen - habe von WMI aber keine Ahnung.

Diese Speicherrechnerei ist echt irr, aber auch verständlich - gibt so viel Speicher dass wohl auch Windows keine Idee mehr hat, wie man das noch verrechnen soll.

Aber nur Mut zur Lücke, wo ein Byte ist, finden sich meist auch Anhänger!
 
21.01.2010  
 




Andreas
Miethe


iF, Beitrag=55898, Zeitpunkt=21.01.2010
Spätestens wohl per WMI abfragbar - vielleicht könnte Roland für WMI eine Stittschnelle bereitstellen - habe von WMI aber keine Ahnung.


Hier die WMI-Schnittstelle mit einem kleinen Beispiel
 $H windows.ph
####################
benötigte Dlls laden
Var ole& = ImportDll("ole32.dll","")
Var oleaut& = ImportDll("oleaut32.dll","")
####################
####################
Hilfsfunktionen

Proc StringToBStr

    Parameters s$
    Var Unicode$ = Space$((Len(S$)*2)+1)
    ~MultiByteToWideChar(0,0,Addr(S$),-1,Addr(Unicode$),Len(Unicode$))
    return SysAllocString(addr(Unicode$))

EndProc

Proc UniToPrf

    Parameters U&
    Var P$ = Space$(1000)
    ~WideCharToMultiByte(0,0,U&,-1,Addr(p$),len(P$),0,0)
    return SysAllocString(addr(p$))

EndProc

####################
####################
Konstanten
Def &COINIT_MULTITHREAD  0
Def &RPC_C_AUTHN_LEVEL_CONNECT  2
Def &RPC_C_IMP_LEVEL_IDENTIFY  2
Def &EOAC_NONE  0
Def &RPC_C_AUTHN_WINNT  10
Def &RPC_C_AUTHZ_NONE  0
Def &RPC_C_AUTHN_LEVEL_CALL  3
Def &RPC_C_IMP_LEVEL_IMPERSONATE  3
Def &CLSCTX_INPROC_SERVER  1
Def &wbemFlagReturnImmediately  16
Def &wbemFlagForwardOnly  32
Def &IFlags (&wbemFlagReturnImmediately + &wbemFlagForwardOnly)
Def &WBEM_INFINITE  $FFFFFFFF
Def $WMISeparator = ","
####################
####################
Strukturen
Struct VARIANT = vt%,
wReserved1%,
wReserved2%,
wReserved3%,
Union#(8)
Struct IWbemServices = QueryInterface&,
AddRef&,
Release&,
OpenNamespace&,
CancelAsyncCall&,
QueryObjectSink&,
GetObject&,
GetObjectAsync&,
PutClass&,
PutClassAsync&,
DeleteClass&,
DeleteClassAsync&,
CreateClassEnum&,
CreateClassEnumAsync&,
PutInstance&,
PutInstanceAsync&,
DeleteInstance&,
DeleteInstanceAsync&,
CreateInstanceEnum&,
CreateInstanceEnumAsync&,
ExecQuery&,
ExecQueryAsync&,
ExecNotificationQuery&,
ExecNotificationQueryAsync&,
ExecMethod&,
ExecMethodAsync&
Struct IWbemLocator = QueryInterface&,
AddRef&,
Release&,
ConnectServer&
Struct IEnumWbemClassObject = QueryInterface&,
AddRef&,
Release&,
Reset&,
Next&,
NextAsync&,
Clone&,
Skip&
Struct IWbemClassObject = QueryInterface&,
AddRef&,
Release&,
GetQualifierSet&,
Get&,
Put&,
Delete&,
GetNames&,
BeginEnumeration&,
Next&,
EndEnumeration&,
GetPropertyQualifierSet&,
Clone&,
GetObjectText&,
SpawnDerivedClass&,
SpawnInstance&,
CompareTo&,
GetPropertyOrigin&,
InheritsFrom&,
GetMethod&,
PutMethod&,
DeleteMethod&,
BeginMethodEnumeration&,
NextMethod&,
EndMethodEnumeration&,
GetMethodQualifierSet&,
GetMethodOrigin&
Struct IUnknown =  QueryInterface&,
AddRef&,
Release&
####################
####################
Interfaces
Declare CLSID_IEnumWbemClassObject#
Dim CLSID_IEnumWbemClassObject#,16
Long CLSID_IEnumWbemClassObject#,0 = $1B1CAD8C
Word CLSID_IEnumWbemClassObject#,4 = $2DAB, $11D2
Byte CLSID_IEnumWbemClassObject#,8 = $B6, $04, $00, $10, $4B, $70, $3E, $FD
Declare IID_IEnumWbemClassObject#
Dim IID_IEnumWbemClassObject#,16
Long IID_IEnumWbemClassObject#,0 = $7C857801
Word IID_IEnumWbemClassObject#,4 = $7381, $11CF
Byte IID_IEnumWbemClassObject#,8 = $88, $4D, $00, $AA, $00, $4B, $2E, $24
Declare CLSID_WbemLocator#
Dim CLSID_WbemLocator#,16
Long CLSID_WbemLocator#,0 = $4590F811
Word CLSID_WbemLocator#,4 = $1D3A, $11D0
Byte CLSID_WbemLocator#,8 = $89,$1F,$00,$AA,$00,$4B,$2E,$24
Declare IID_IWbemLocator#
Dim IID_IWbemLocator#,16
Long IID_IWbemLocator#,0 = $DC12A687
Word IID_IWbemLocator#,4 = $737F, $11CF
Byte IID_IWbemLocator#,8 = $88,$4D,$00,$AA,$00,$4B,$2E,$24
Declare IID_IUnknown#
Dim IID_IUnknown#,16
Long IID_IUnknown#,0 = $00000000
Word IID_IUnknown#,4 = $0000, $0000
Byte IID_IUnknown#,8 = $C0, $00, $00, $00, $00, $00, $00, $46
####################
####################
globale Variablen
Declare Variant#,Union#,IWbemLocator#,IWbemServices#,IEnumWbemClassObject#,IWbemClassObject#,IUnknown#
Declare IWbemLocator&,IWbemServices&,IUnknown&,IEnumWbemClassObject&,IWbemClassObject&
Dim Variant#, VARIANT
Union# = Variant# + 8
Dim IWbemLocator#,IWbemLocator
Dim IWbemServices#,IWbemServices
Dim IEnumWbemClassObject#,IEnumWbemClassObject
Dim IWbemClassObject#,IWbemClassObject
Dim IUnknown#,IUnknown
####################

Proc FillInterface

    Interface-Strukturen füllen
    Parameters IFace#

    WhileLoop 0, SizeOf(IFace#)-4,4

        Long IFace#,&Loop = &Loop

    EndWhile

Endproc

Proc wmi_release

    Freigaben
    Parameters dummy$
    Case IWbemServices& <> 0 : Call(Long(Long(IWbemServices&,0),IWbemServices#.Release&),IWbemServices&)
    Case IWbemLocator& <> 0: Call(Long(Long(IWbemLocator&,0),IWbemLocator#.Release&),IWbemLocator&)
    Case IEnumWbemClassObject& <> 0 : Call(Long(Long(IEnumWbemClassObject&,0),IEnumWbemClassObject#.Release&),IEnumWbemClassObject&)
    Case IWbemClassObject& <> 0: Call(Long(Long(IWbemClassObject&,0),IWbemClassObject#.Release&),IWbemClassObject&)
    CoUninitialize()

    If Instr(dummy$, "Fehler", 1)

        MessageBox("", dummy)
        End

    EndIf

EndProc

Proc wmi_init

    WMI initialisieren
    Declare hRes&
    Var txt$ = ""
    CoInitializeEx(0,&COINIT_MULTITHREAD)
    hres& = CoInitializeSecurity(0, -1,0,0,&RPC_C_AUTHN_LEVEL_CONNECT,&RPC_C_IMP_LEVEL_IDENTIFY,0,&EOAC_NONE,0)

    If hres& <> 0: txt$="Fehler: nicht möglich CoInitializeSecurity aufzurufen": wmi_release(txt$): EndIf

        hres& = CoCreateInstance(CLSID_WbemLocator#,0,&CLSCTX_INPROC_SERVER,IID_IWbemLocator#,addr(IWbemLocator&))

        If hres& <> 0: txt$="Fehler: nicht möglich CoCreateInstance aufzurufen": wmi_release(txt$): EndIf €

            hRes& = Call(Long(Long(IWbemLocator&,0),IWbemLocator#.ConnectServer&),IWbemLocator&,StringToBStr("root\cimv2"),0,0,0,0,0,0,addr(IWbemServices&))

            If hres& <> 0: txt$="Fehler: micht möglich IWbemLocator.ConnectServer aufzurufen": wmi_release(txt$): EndIf

                hRes& = Call(Long(Long(IWbemServices&,0),IWbemServices#.QueryInterface&),IWbemServices&,IID_IUnknown#,Addr(IUnknown&))
                hres&=CoSetProxyBlanket(IWbemServices&,&RPC_C_AUTHN_WINNT,&RPC_C_AUTHZ_NONE,0,&RPC_C_AUTHN_LEVEL_CALL,&RPC_C_IMP_LEVEL_IMPERSONATE,0,&EOAC_NONE)

                If hres& <> 0: txt$="Fehler: nicht möglich CoSetProxyBlanket aufzurufen": wmi_release(txt$): EndIf

                    hres&=CoSetProxyBlanket(IUnknown&,&RPC_C_AUTHN_WINNT,&RPC_C_AUTHZ_NONE,0,&RPC_C_AUTHN_LEVEL_CALL,&RPC_C_IMP_LEVEL_IMPERSONATE,0,&EOAC_NONE)

                    If hres& <> 0: txt$="Fehler: nicht möglich CoSetProxyBlanket aufzurufen": wmi_release(txt$): EndIf

                        Call(Long(Long(IUnknown&,0),IUnknown#.Release&),IUnknown&)
                        Return txt$

                    EndProc

                    Proc wmi_call

                        WMI-Aufruf
                        Parameter(3) Select-Anweisung,Auswahl
                        Rückgabe erfolgt in einer Stringliste
                        wmi_init()
                        Parameters Command$,Vars$
                        Var CountVars& = 1
                        Var hList& =  @create("List",0)
                        Var RetList& =  @create("List",0)
                        ClearList hList&

                        Whileloop 1,Len(Vars$)

                            If Mid$(Vars$,&loop,1)=","

                                Inc Countvars&

                            Endif

                        Endwhile

                        Whileloop 1,Countvars&

                            AddString(hList&, Substr$(Vars$,&loop,","))

                        Endwhile

                        Declare hres&,uReturn&,nDim&,plUBound&,A$,rgVar&,z&,obj&
                        Obj& = 1
                        Call(Long(Long(IWbemServices&,0),IWbemServices#.ExecQuery&),IWbemServices&,StringToBStr("WQL"),StringToBStr(command$),0,0,Addr(IEnumWbemClassObject&))

                        If hres& <> 0: txt$="Fehler: nicht möglich IWbemServices::ExecQuery aufzurufen": wmi_release(txt$): EndIf

                            hres& = Call(Long(Long(IEnumWbemClassObject&,0),IEnumWbemClassObject#.Reset&),IEnumWbemClassObject&)

                            If hres& = 0: txt$="Fehler: nicht möglich IEnumWbemClassObject::aufzurufen": wmi_release(txt$): EndIf

                                Var NO& = 1

                                While NO&

                                    hRes& = Call(Long(Long(IEnumWbemClassObject&,0),IEnumWbemClassObject#.Next&),IEnumWbemClassObject&,&WBEM_INFINITE,1,Addr(IWbemClassObject&),Addr(uReturn&))

                                    If hRes& = 0 : NO& = 1 : Endif

                                        If uReturn& <> 0

                                            Whileloop 1,Countvars&

                                                hRes& = Call(Long(Long(IWbemClassObject&,0),IWbemClassObject#.Get&),IWbemClassObject&,StringToBStr(Getstring$(hList&,&loop-1)),0,Variant#,0,0)Select Word(Variant#,0)

                                                Select Variant#.vt%

                                                    Caseof 1

                                                    AddString(RetList&,"n/a")

                                                    Caseof 3

                                                    AddString(RetList&,Str$(Long(Union#,0)))

                                                    Caseof 8

                                                    If Instr("Date",Getstring$(hList&,&loop-1)) Or Instr("Time",Getstring$(hList&,&loop-1))

                                                        A$ = String$(UniToPrf(Long(Union#,0)),0)
                                                        A$ = Mid$(A$, 7, 2)+"."+Mid$(A$, 5, 2)+"."+Mid$(A$, 1, 4)+" "+Mid$(A$, 9, 2)+":"+Mid$(A$, 11,2)+":"+Mid$(A$, 13,2)
                                                        AddString(RetList&,+A$)

                                                    else

                                                        AddString(RetList&,String$(UniToPrf(Long(Union#,0)),0))

                                                    endif

                                                    Caseof 11

                                                    If byte(Union#,0) = 0

                                                        AddString(RetList&,"falsch")

                                                    Else

                                                        AddString(RetList&,"falsch")

                                                    Endif

                                                    Caseof 8195

                                                    nDim&=SafeArrayGetDim(Long(Union#,0))
                                                    A$ = ""
                                                    z& = 0
                                                    SafeArrayGetUBound(Long(Union#,0), nDim&, Addr(plUbound&))

                                                    Whileloop 0,plUbound&

                                                        SafeArrayGetElement(Long(Union#,0),addr(&loop), Addr(rgVar&))
                                                        A$ = A$ + ","+Str$(rgVar&)

                                                    EndWhile

                                                    A$ = Mid$(A$,2,Len(A$))
                                                    AddString(RetList&,A$)

                                                    Caseof 8200

                                                    nDim&=SafeArrayGetDim(Long(Union#,0))
                                                    A$ = ""
                                                    z& = 0
                                                    SafeArrayGetUBound(Long(Union#,0), nDim&, Addr(plUbound&))

                                                    Whileloop 0,plUbound&

                                                        SafeArrayGetElement(Long(Union#,0),addr(&loop), Addr(rgVar&))
                                                        A$ = A$ + ","+String$(UnitoPrf(rgVar&),0)

                                                    EndWhile

                                                    A$ = Mid$(A$,2,Len(A$))
                                                    AddString(RetList&,Getstring$(hList&,&loop-1)+" : "+ A$)

                                                endselect

                                            endwhile

                                        Else

                                            NO& = 0

                                        Endif

                                        Inc Obj&

                                    EndWhile

                                Endif

                                wmi_release()
                                Return Retlist&

                            Endproc

                            Proc FreeWMI

                                Dispose Variant#,Union#,IWbemLocator#,IWbemServices#,IEnumWbemClassObject#,IWbemClassObject#,IUnknown#

                            Endproc

                            ####################
                            Interface-Strukuren füllen
                            FillInterface(IWbemLocator#)
                            FillInterface(IWbemServices#)
                            FillInterface(IEnumWbemClassObject#)
                            FillInterface(IWbemClassObject#)
                            FillInterface(IUnknown#)
                            ####################
                            ###################################################
                            TEST
                            ###################################################
                            Decimals 2
                            windowstyle 527
                            cls
                            Var Div! = 1024^2
                            Var Div3! = 1024^3
                            Var TotalMem! = 0
                            Var MemAVail! = 0
                            Kapazität der installierten Speicherbausteine abfragen.
                            Je Baustein wird ein ein String in eine Stringliste hinzugefügt.
                            In der Schleife werden die Einzel-Kapazitäten zusammengezählt.
                            Var l& = wmi_call("SELECT * FROM Win32_PhysicalMemory","Capacity")

                            Whileloop 0,GetCount(l&)-1

                                TotalMem! = TotalMem! + Val(GetString$(l&,&Loop))

                            Endwhile

                            Kapazität des Arbeitsspeichers, der von Windows für den User zur
                            Verfügung gestellt wird
                            L& =wmi_call("SELECT * FROM Win32_ComputerSystem","TotalPhysicalMemory")

                            Whileloop 0,GetCount(l&)-1,2

                                MemAvail! = MemAvail! + Val(GetString$(l&,&Loop))

                            Endwhile

                            Ausgeben

                            If TotalMem! <> 0

                                Print "Physikalischer Speicher : ",TotalMem!/div!,"MB"

                            Else

                                Print "Physikalischer Speicher : ",GetMem()/div!,"MB"

                            Endif

                            Print "Arbeitsspeicher total   : ",MemAvail!/div!,"MB"
                            Kapazität der Partitionen
                            Es werden 3 Werte pro Partition abgefragt, daher in der Schleife Step 3
                            Es werden nur Partitionen abgefragt deren Grösse > 0 ist.
                            D.h. keine leeren CD-Laufwerke
                            Locate 6,0
                            l& = wmi_call("SELECT * FROM Win32_LogicalDisk where Size > 0","Name,Freespace,Size")

                            Whileloop 0,GetCount(l&)-1,3

                                Ausgeben
                                Print GetString$(l&,&Loop),"Frei :" ,Val(GetString$(l&,&Loop+1))/div3!,"GB ","Total :",Val(GetString$(l&,&Loop+2))/div3!,"GB"

                            Endwhile

                            Proc showmem

                                Kontinuierliche Abfrage des freien Speichers
                                Var Freespace! = 0
                                Var Avail! = 0
                                Var Size! = 0
                                locate 3,0
                                Locate 6,0
                                l& = wmi_call("SELECT * FROM Win32_LogicalDisk where Size > 0","Name,Freespace,Size")

                                Whileloop 0,GetCount(l&)-1,3

                                    Ausgeben
                                    Print GetString$(l&,&Loop),"Frei :" ,Val(GetString$(l&,&Loop+1))/div3!,"GB ","Total :",Val(GetString$(l&,&Loop+2))/div3!,"GB"

                                Endwhile

                                Print Space$(50)
                                locate 3,0
                                L& =wmi_call("SELECT * FROM Win32_PerfRawData_PerfOS_Memory","AvailableBytes")

                                Whileloop 0,GetCount(l&)-1

                                    Avail! = Avail! + Val(GetString$(l&,&Loop))

                                Endwhile

                                Print "Speicher frei           : ",Avail!/div!,"MB"
                                Print "Speicher benutzt        : ",(MemAvail!-Avail!)/div!,"MB"
                                Print ""

                            EndProc

                            showmem()
                            Var ende& = 0

                            Whilenot ende&

                                waitinput 100

                                If %Key = 2

                                    Ende& = 1

                                endif

                                showmem()

                            Endwhile

                            FreeWMI()
                            end

                            Proc GetMem

                                Struct MEMORYSTATUSEX =
                                dwLength&,
                                dwMemoryLoad&,
                                ullTotalPhysLow&,
                                ullTotalPhysHi&,
                                ullAvailPhysLow&,
                                ullAvailPhysHi&,
                                ullTotalPageFileLow&,
                                ullTotalPageFileHi&,
                                ullAvailPageFileLow&,
                                ullAvailPageFileHi&,
                                ullTotalVirtualLow&,
                                ullTotalVirtualHi&,
                                ullAvailVirtualLow&,
                                ullAvailVirtualHi&,
                                ullAvailExtendedVirtualLow&,
                                ullAvailExtendedVirtualHi&
                                Var Memory# = New(MEMORYSTATUSEX)
                                Memory#.dwLength& = SizeOf(Memory#)
                                External("Kernel32.dll","GlobalMemoryStatusEx",Memory#)
                                Var TotalMem! = 0
                                Totalmem! = Memory#.ullTotalPhysLow&
                                case Memory#.ullTotalPhysLow& < 0: TotalMem! =  Memory#.ullTotalPhysLow& + (2^32)
                                TotalMem! = (Memory#.ullTotalPhysHi& * (2^32)) + TotalMem!
                                Dispose Memory#
                                Return TotalMem!

                            EndProc

 
Gruss
Andreas
________ ________ ________ ________ _
Profan 3.3 - XProfanX2
Win 95,98,ME,2000,XP,Vista - Win 7 32 / 64 Bit
ASUS X93S - Intel Core I7-NVIDIA GForce 540M 8GB Arbeitsspeicher
Homepage :  [...] 
21.01.2010  
 



Jaul, klasse! Wenn ich wieder in Dt. bin! Dann! Hoho!
 
21.01.2010  
 




E.T.
Einfach Cool
 
Grüße aus Sachsen... Mario WinXP, Win7 (64 Bit),Win8(.1), Profan 6 - X4, XPSE, und 'nen schwarzes, blinkendes Dingens, wo ich das alles reinschütte...
Guggst du hier:  [...] 
Aussichten:  [...] 
22.01.2010  
 




Jörg
Sellmeyer
Hab versucht, das mal wiederherzustellen. Leider gibt es zwischen $B "1" und $B "1.1" ne Schutzverletzung.
'Andreas Miethe
 $H windows.ph
'####################
'benötigte Dlls laden
Var ole& = ImportDll("ole32.dll","")
Var oleaut& = ImportDll("oleaut32.dll","")
'####################
'####################
'Hilfsfunktionen

Proc StringToBStr

    Parameters s$
    Var Unicode$ = Space$((Len(S$)*2)+1)
    ~MultiByteToWideChar(0,0,Addr(S$),-1,Addr(Unicode$),Len(Unicode$))
    return SysAllocString(addr(Unicode$))

EndProc

Proc UniToPrf

    Parameters U&
    Var P$ = Space$(1000)
    ~WideCharToMultiByte(0,0,U&,-1,Addr(p$),len(P$),0,0)
    return SysAllocString(addr(p$))

EndProc

'####################
'####################
'Konstanten
Def &COINIT_MULTITHREAD  0
Def &RPC_C_AUTHN_LEVEL_CONNECT  2
Def &RPC_C_IMP_LEVEL_IDENTIFY  2
Def &EOAC_NONE  0
Def &RPC_C_AUTHN_WINNT  10
Def &RPC_C_AUTHZ_NONE  0
Def &RPC_C_AUTHN_LEVEL_CALL  3
Def &RPC_C_IMP_LEVEL_IMPERSONATE  3
Def &CLSCTX_INPROC_SERVER  1
Def &wbemFlagReturnImmediately  16
Def &wbemFlagForwardOnly  32
Def &IFlags (&wbemFlagReturnImmediately + &wbemFlagForwardOnly)
Def &WBEM_INFINITE  $FFFFFFFF
Def $WMISeparator = ","
'####################
'####################
'Strukturen
Struct VARIANT = vt%,\
wReserved1%,\
wReserved2%,\
wReserved3%,\
Union#(8)
Struct IWbemServices = QueryInterface&,\
AddRef&,\
Release&,\
OpenNamespace&,\
CancelAsyncCall&,\
QueryObjectSink&,\
GetObject&,\
GetObjectAsync&,\
PutClass&,\
PutClassAsync&,\
DeleteClass&,\
DeleteClassAsync&,\
CreateClassEnum&,\
CreateClassEnumAsync&,\
PutInstance&,\
PutInstanceAsync&,\
DeleteInstance&,\
DeleteInstanceAsync&,\
CreateInstanceEnum&,\
CreateInstanceEnumAsync&,\
ExecQuery&,\
ExecQueryAsync&,\
ExecNotificationQuery&,\
ExecNotificationQueryAsync&,\
ExecMethod&,\
ExecMethodAsync&
Struct IWbemLocator = QueryInterface&,\
AddRef&,\
Release&,\
ConnectServer&
Struct IEnumWbemClassObject = QueryInterface&,\
AddRef&,\
Release&,\
Reset&,\
Next&,\
NextAsync&,\
Clone&,\
Skip&
Struct IWbemClassObject = QueryInterface&,\
AddRef&,\
Release&,\
GetQualifierSet&,\
Get&,\
Put&,\
Delete&,\
GetNames&,\
BeginEnumeration&,\
Next&,\
EndEnumeration&,\
GetPropertyQualifierSet&,\
Clone&,\
GetObjectText&,\
SpawnDerivedClass&,\
SpawnInstance&,\
CompareTo&,\
GetPropertyOrigin&,\
InheritsFrom&,\
GetMethod&,\
PutMethod&,\
DeleteMethod&,\
BeginMethodEnumeration&,\
NextMethod&,\
EndMethodEnumeration&,\
GetMethodQualifierSet&,\
GetMethodOrigin&
Struct IUnknown =  QueryInterface&,\
AddRef&,\
Release&
'####################
'####################
'Interfaces
Declare CLSID_IEnumWbemClassObject#
Dim CLSID_IEnumWbemClassObject#,16
Long CLSID_IEnumWbemClassObject#,0 = $1B1CAD8C
Word CLSID_IEnumWbemClassObject#,4 = $2DAB, $11D2
Byte CLSID_IEnumWbemClassObject#,8 = $B6, $04, $00, $10, $4B, $70, $3E, $FD
Declare IID_IEnumWbemClassObject#
Dim IID_IEnumWbemClassObject#,16
Long IID_IEnumWbemClassObject#,0 = $7C857801
Word IID_IEnumWbemClassObject#,4 = $7381, $11CF
Byte IID_IEnumWbemClassObject#,8 = $88, $4D, $00, $AA, $00, $4B, $2E, $24
Declare CLSID_WbemLocator#
Dim CLSID_WbemLocator#,16
Long CLSID_WbemLocator#,0 = $4590F811
Word CLSID_WbemLocator#,4 = $1D3A, $11D0
Byte CLSID_WbemLocator#,8 = $89,$1F,$00,$AA,$00,$4B,$2E,$24
Declare IID_IWbemLocator#
Dim IID_IWbemLocator#,16
Long IID_IWbemLocator#,0 = $DC12A687
Word IID_IWbemLocator#,4 = $737F, $11CF
Byte IID_IWbemLocator#,8 = $88,$4D,$00,$AA,$00,$4B,$2E,$24
Declare IID_IUnknown#
Dim IID_IUnknown#,16
Long IID_IUnknown#,0 = $00000000
Word IID_IUnknown#,4 = $0000, $0000
Byte IID_IUnknown#,8 = $C0, $00, $00, $00, $00, $00, $00, $46
'####################
'####################
'globale Variablen
Declare Variant#,Union#,IWbemLocator#,IWbemServices#,IEnumWbemClassObject#,IWbemClassObject#,IUnknown#
Declare IWbemLocator&,IWbemServices&,IUnknown&,IEnumWbemClassObject&,IWbemClassObject&
Dim Variant#, VARIANT
Union# = Variant# + 8
Dim IWbemLocator#,IWbemLocator
Dim IWbemServices#,IWbemServices
Dim IEnumWbemClassObject#,IEnumWbemClassObject
Dim IWbemClassObject#,IWbemClassObject
Dim IUnknown#,IUnknown
'####################

Proc FillInterface

    'Interface-Strukturen füllen
    Parameters IFace#

    WhileLoop 0, SizeOf(IFace#)-4,4

        Long IFace#,&Loop = &Loop

    EndWhile

Endproc

Proc wmi_release

    'Freigaben
    Parameters dummy$
    Case IWbemServices& <> 0 : Call(Long(Long(IWbemServices&,0),IWbemServices#.Release&),IWbemServices&)
    Case IWbemLocator& <> 0: Call(Long(Long(IWbemLocator&,0),IWbemLocator#.Release&),IWbemLocator&)
    Case IEnumWbemClassObject& <> 0 : Call(Long(Long(IEnumWbemClassObject&,0),IEnumWbemClassObject#.Release&),IEnumWbemClassObject&)
    Case IWbemClassObject& <> 0: Call(Long(Long(IWbemClassObject&,0),IWbemClassObject#.Release&),IWbemClassObject&)
    CoUninitialize()

    If Instr(dummy$, "Fehler", 1)

        MessageBox("", dummy)
        End

    EndIf

EndProc

Proc wmi_init

    'WMI initialisieren
    Declare hRes&
    Var txt$ = ""
    CoInitializeEx(0,&COINIT_MULTITHREAD)
    hres& = CoInitializeSecurity(0, -1,0,0,&RPC_C_AUTHN_LEVEL_CONNECT,&RPC_C_IMP_LEVEL_IDENTIFY,0,&EOAC_NONE,0)

    If hres& <> 0: txt$="Fehler: nicht möglich CoInitializeSecurity aufzurufen": wmi_release(txt$): EndIf

        hres& = CoCreateInstance(CLSID_WbemLocator#,0,&CLSCTX_INPROC_SERVER,IID_IWbemLocator#,addr(IWbemLocator&))

        If hres& <> 0: txt$="Fehler: nicht möglich CoCreateInstance aufzurufen": wmi_release(txt$): EndIf €

            hRes& = Call(Long(Long(IWbemLocator&,0),IWbemLocator#.ConnectServer&),IWbemLocator&,StringToBStr("root\cimv2"),0,0,0,0,0,0,addr(IWbemServices&))

            If hres& <> 0: txt$="Fehler: micht möglich IWbemLocator.ConnectServer aufzurufen": wmi_release(txt$): EndIf

                hRes& = Call(Long(Long(IWbemServices&,0),IWbemServices#.QueryInterface&),IWbemServices&,IID_IUnknown#,Addr(IUnknown&))
                hres&=CoSetProxyBlanket(IWbemServices&,&RPC_C_AUTHN_WINNT,&RPC_C_AUTHZ_NONE,0,&RPC_C_AUTHN_LEVEL_CALL,&RPC_C_IMP_LEVEL_IMPERSONATE,0,&EOAC_NONE)

                If hres& <> 0: txt$="Fehler: nicht möglich CoSetProxyBlanket aufzurufen": wmi_release(txt$): EndIf

                    hres&=CoSetProxyBlanket(IUnknown&,&RPC_C_AUTHN_WINNT,&RPC_C_AUTHZ_NONE,0,&RPC_C_AUTHN_LEVEL_CALL,&RPC_C_IMP_LEVEL_IMPERSONATE,0,&EOAC_NONE)

                    If hres& <> 0: txt$="Fehler: nicht möglich CoSetProxyBlanket aufzurufen": wmi_release(txt$): EndIf

                        Call(Long(Long(IUnknown&,0),IUnknown#.Release&),IUnknown&)
                        Return txt$

                    EndProc

                    Proc wmi_call

                        'WMI-Aufruf
                        'Parameter(3) Select-Anweisung,Auswahl
                        'Rückgabe erfolgt in einer Stringliste
                        wmi_init()
                        Parameters Command$,Vars$
                        Var CountVars& = 1
                        Var hList& =  @create("List",0)
                        Var RetList& =  @create("List",0)
                        Var txt$ = ""
                        ClearList hList&

                        Whileloop 1,Len(Vars$)

                            If Mid$(Vars$,&loop,1)=","

                                Inc Countvars&

                            Endif

                        Endwhile

                        Whileloop 1,Countvars&

                            AddString(hList&, Substr$(Vars$,&loop,","))

                        Endwhile

                        Declare hres&,uReturn&,nDim&,plUBound&,A$,rgVar&,z&,obj&
                        Obj& = 1
                        Call(Long(Long(IWbemServices&,0),IWbemServices#.ExecQuery&),IWbemServices&,StringToBStr("WQL"),StringToBStr(command$),0,0,Addr(IEnumWbemClassObject&))

                        If hres& <> 0: txt$="Fehler: nicht möglich IWbemServices::ExecQuery aufzurufen": wmi_release(txt$): EndIf

                            hres& = Call(Long(Long(IEnumWbemClassObject&,0),IEnumWbemClassObject#.Reset&),IEnumWbemClassObject&)

                            If hres& = 0: txt$="Fehler: nicht möglich IEnumWbemClassObject::aufzurufen": wmi_release(txt$): EndIf

                                Var NO& = 1

                                While NO&

                                     $B "1"
                                    hRes& = Call(Long(Long(IEnumWbemClassObject&,0),IEnumWbemClassObject#.Next&),IEnumWbemClassObject&,&WBEM_INFINITE,1,Addr(IWbemClassObject&),Addr(uReturn&))
                                     $B "1.1"

                                    If hRes& = 0 : NO& = 1 : Endif

                                        If uReturn& <> 0

                                            Whileloop 1,Countvars&

                                                hRes& = Call(Long(Long(IWbemClassObject&,0),IWbemClassObject#.Get&),IWbemClassObject&,StringToBStr(Getstring$(hList&,&loop-1)),0,Variant#,0,0)Select Word(Variant#,0)

                                                Select Variant#.vt%

                                                    Caseof 1

                                                    AddString(RetList&,"n/a")

                                                    Caseof 3

                                                    AddString(RetList&,Str$(Long(Union#,0)))

                                                    Caseof 8

                                                    If Instr("Date",Getstring$(hList&,&loop-1)) Or Instr("Time",Getstring$(hList&,&loop-1))

                                                        A$ = String$(UniToPrf(Long(Union#,0)),0)
                                                        A$ = Mid$(A$, 7, 2)+"."+Mid$(A$, 5, 2)+"."+Mid$(A$, 1, 4)+" "+Mid$(A$, 9, 2)+":"+Mid$(A$, 11,2)+":"+Mid$(A$, 13,2)
                                                        AddString(RetList&,+A$)

                                                    else

                                                        AddString(RetList&,String$(UniToPrf(Long(Union#,0)),0))

                                                    endif

                                                    Caseof 11

                                                    If byte(Union#,0) = 0

                                                        AddString(RetList&,"falsch")

                                                    Else

                                                        AddString(RetList&,"falsch")

                                                    Endif

                                                    Caseof 8195

                                                    nDim&=SafeArrayGetDim(Long(Union#,0))
                                                    A$ = ""
                                                    z& = 0
                                                    SafeArrayGetUBound(Long(Union#,0), nDim&, Addr(plUbound&))

                                                    Whileloop 0,plUbound&

                                                        SafeArrayGetElement(Long(Union#,0),addr(&loop), Addr(rgVar&))
                                                        A$ = A$ + ","+Str$(rgVar&)

                                                    EndWhile

                                                    A$ = Mid$(A$,2,Len(A$))
                                                    AddString(RetList&,A$)

                                                    Caseof 8200

                                                    nDim&=SafeArrayGetDim(Long(Union#,0))
                                                    A$ = ""
                                                    z& = 0
                                                    SafeArrayGetUBound(Long(Union#,0), nDim&, Addr(plUbound&))

                                                    Whileloop 0,plUbound&

                                                        SafeArrayGetElement(Long(Union#,0),addr(&loop), Addr(rgVar&))
                                                        A$ = A$ + ","+String$(UnitoPrf(rgVar&),0)

                                                    EndWhile

                                                    A$ = Mid$(A$,2,Len(A$))
                                                    AddString(RetList&,Getstring$(hList&,&loop-1)+" : "+ A$)

                                                endselect

                                            endwhile

                                        Else

                                            NO& = 0

                                        Endif

                                        Inc Obj&

                                    EndWhile

                                Endif

                                wmi_release()
                                Return Retlist&

                            Endproc

                            Proc FreeWMI

                                Dispose Variant#,Union#,IWbemLocator#,IWbemServices#,IEnumWbemClassObject#,IWbemClassObject#,IUnknown#

                            Endproc

                            '####################
                            'Interface-Strukuren füllen
                            FillInterface(IWbemLocator#)
                            FillInterface(IWbemServices#)
                            FillInterface(IEnumWbemClassObject#)
                            FillInterface(IWbemClassObject#)
                            FillInterface(IUnknown#)
                            '####################
                            '###################################################
                            'TEST
                            '###################################################
                            Set("Decimals", 2)
                            windowstyle 527
                            cls
                            Var Div! = 1024^2
                            Var Div3! = 1024^3
                            Var TotalMem! = 0
                            Var MemAVail! = 0
                            '                            Kapazität der installierten Speicherbausteine abfragen.
                            '                            Je Baustein wird ein ein String in eine Stringliste hinzugefügt.
                            '                            In der Schleife werden die Einzel-Kapazitäten zusammengezählt.
                            'traceon
                            Var l& = wmi_call("SELECT * FROM Win32_PhysicalMemory","Capacity")
                             $B "2"

                            Whileloop 0,GetCount(l&)-1

                                TotalMem! = TotalMem! + Val(GetString$(l&,&Loop))

                            Endwhile

                            '                            Kapazität des Arbeitsspeichers, der von Windows für den User zur
                            '                            Verfügung gestellt wird
                            L& =wmi_call("SELECT * FROM Win32_ComputerSystem","TotalPhysicalMemory")

                            Whileloop 0,GetCount(l&)-1,2

                                MemAvail! = MemAvail! + Val(GetString$(l&,&Loop))

                            Endwhile

                             $B "3"
                            '                            Ausgeben

                            If TotalMem! <> 0

                                Print "Physikalischer Speicher : ",TotalMem!/div!,"MB"

                            Else

                                Print "Physikalischer Speicher : ",GetMem()/div!,"MB"

                            Endif

                            Print "Arbeitsspeicher total   : ",MemAvail!/div!,"MB"
                            '                            Kapazität der Partitionen
                            '                            Es werden 3 Werte pro Partition abgefragt, daher in der Schleife Step 3
                            '                            Es werden nur Partitionen abgefragt deren Grösse > 0 ist.
                            '                            D.h. keine leeren CD-Laufwerke
                            Locate 6,0
                             $B "4"
                            l& = wmi_call("SELECT * FROM Win32_LogicalDisk where Size > 0","Name,Freespace,Size")

                            Whileloop 0,GetCount(l&)-1,3

                                '                                Ausgeben
                                Print GetString$(l&,&Loop),"Frei :" ,Val(GetString$(l&,&Loop+1))/div3!,"GB ","Total :",Val(GetString$(l&,&Loop+2))/div3!,"GB"

                            Endwhile

                            Proc showmem

                                '                                Kontinuierliche Abfrage des freien Speichers
                                Var Freespace! = 0
                                Var Avail! = 0
                                Var Size! = 0
                                locate 3,0
                                Locate 6,0
                                l& = wmi_call("SELECT * FROM Win32_LogicalDisk where Size > 0","Name,Freespace,Size")

                                Whileloop 0,GetCount(l&)-1,3

                                    '                                    Ausgeben
                                    Print GetString$(l&,&Loop),"Frei :" ,Val(GetString$(l&,&Loop+1))/div3!,"GB ","Total :",Val(GetString$(l&,&Loop+2))/div3!,"GB"

                                Endwhile

                                Print Space$(50)
                                locate 3,0
                                L& =wmi_call("SELECT * FROM Win32_PerfRawData_PerfOS_Memory","AvailableBytes")

                                Whileloop 0,GetCount(l&)-1

                                    Avail! = Avail! + Val(GetString$(l&,&Loop))

                                Endwhile

                                Print "Speicher frei           : ",Avail!/div!,"MB"
                                Print "Speicher benutzt        : ",(MemAvail!-Avail!)/div!,"MB"
                                Print ""

                            EndProc

                            showmem()
                            Var ende& = 0

                            Whilenot ende&

                                waitinput 100

                                If %Key = 2

                                    Ende& = 1

                                endif

                                showmem()

                            Endwhile

                            FreeWMI()
                            end

                            Proc GetMem

                                Struct MEMORYSTATUSEX =\
                                dwLength&,\
                                dwMemoryLoad&,\
                                ullTotalPhysLow&,\
                                ullTotalPhysHi&,\
                                ullAvailPhysLow&,\
                                ullAvailPhysHi&,\
                                ullTotalPageFileLow&,\
                                ullTotalPageFileHi&,\
                                ullAvailPageFileLow&,\
                                ullAvailPageFileHi&,\
                                ullTotalVirtualLow&,\
                                ullTotalVirtualHi&,\
                                ullAvailVirtualLow&,\
                                ullAvailVirtualHi&,\
                                ullAvailExtendedVirtualLow&,\
                                ullAvailExtendedVirtualHi&
                                Var Memory# = New(MEMORYSTATUSEX)
                                Memory#.dwLength& = SizeOf(Memory#)
                                External("Kernel32.dll","GlobalMemoryStatusEx",Memory#)
                                Var TotalMem! = 0
                                Totalmem! = Memory#.ullTotalPhysLow&
                                case Memory#.ullTotalPhysLow& < 0: TotalMem! =  Memory#.ullTotalPhysLow& + (2^32)
                                TotalMem! = (Memory#.ullTotalPhysHi& * (2^32)) + TotalMem!
                                Dispose Memory#
                                Return TotalMem!

                            EndProc

 
XProfan X4
Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...
12.06.2018  
 




Michael
W.
erstmal richtig einrücken. da ist evtl ein "endif" zu viel. wenn ein solches auskommentiert war, dann prost...
 
Alle Sprachen
System: Windows 8/10, XProfan X4
Programmieren, das spannendste Detektivspiel der Welt.
13.06.2018  
 




Jörg
Sellmeyer
Nein, es knallt genau bei dieser fUNKTION.
 $B "1"
hRes& = Call(Long(Long(IEnumWbemClassObject&,0),IEnumWbemClassObject#.Next&),IEnumWbemClassObject&,&WBEM_INFINITE,1,Addr(IWbemClassObject&),Addr(uReturn&))
 $B "1.1"
 
XProfan X4
Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...
13.06.2018  
 



Auch mit X11?
 
13.06.2018  
 




Jörg
Sellmeyer
Ich hab das Addr auch mal weggelassen, falls du das meinst. Ansonsten: was ist X11 ?
 
XProfan X4
Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...
14.06.2018  
 




p.specht
Free!
 
XProfan 11
So Computer sind halt auch nur Menschen...
14.06.2018  
 



 
- Seite 2 -



E.T.
Mit XProfan 11.2 läufts auch nicht

Edit: Ich glaub, ich hab's in meiner "Sammlung" gefunden, wenn jemand Lust hat kann er ja mal vergleichen (mir fehlt grad die Zeit dazu)

 
Grüße aus Sachsen... Mario WinXP, Win7 (64 Bit),Win8(.1), Profan 6 - X4, XPSE, und 'nen schwarzes, blinkendes Dingens, wo ich das alles reinschütte...
Guggst du hier:  [...] 
Aussichten:  [...] 
14.06.2018  
 




Zum Quelltext


Thementitel, max. 100 Zeichen.
 

Systemprofile:

Kein Systemprofil angelegt. [anlegen]

XProfan:

 Beitrag  Schrift  Smilies  ▼ 

Bitte anmelden um einen Beitrag zu verfassen.
 

Themenoptionen

5.403 Betrachtungen

Unbenanntvor 0 min.
Thomas Zielinski06.09.2019
Pedro Miguel17.05.2019
p.specht09.05.2019
Sascha Haak13.01.2019
Mehr...

Themeninformationen



AGB  |  Chat  |  Datenschutz  |  Download  |  Eingangshalle  |  Hilfe  |  Impressum  |  Mart  |  Support  |  Suche

Ein Projekt aller XProfaner, die es gibt!


Mein XProfan
Private Nachrichten
Eigenes Ablageforum
Themen-Merkliste
Eigene Beiträge
Eigene Themen
Zwischenablage
Abmelden
 Deutsch English Français Español Italia
Übersetzungen

Datenschutz


Wir verwenden Cookies nur als Session-Cookies wegen der technischen Notwendigkeit und bei uns gibt es keine Cookies von Drittanbietern.

Wenn du hier auf unsere Webseite klickst oder navigierst, stimmst du unserer Erfassung von Informationen in unseren Cookies auf XProfan.Net zu.

Weitere Informationen zu unseren Cookies und dazu, wie du die Kontrolle darüber behältst, findest du in unserer nachfolgenden Datenschutzerklärung.


einverstandenDatenschutzerklärung
Ich möchte keinen Cookie