Quelltexte/ Codesnippets | | | | | | - 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
|
| | | | | | |
| | | | | | | - 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  |
| | | | Grüße aus Sachsen... Mario  WinXP, Win7 (64 Bit),Win8(.1),Win10, Win 11, Profan 6 - X4, XPSE, und 'nen schwarzes, blinkendes Dingens, wo ich das alles reinschütte... | 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!  |
| | | | | | |
| | 
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! |
| | | | | | |
| |
E.T. | Einfach Cool   |
| | | | Grüße aus Sachsen... Mario WinXP, Win7 (64 Bit),Win8(.1),Win10, Win 11, Profan 6 - X4, XPSE, und 'nen schwarzes, blinkendes Dingens, wo ich das alles reinschütte... | 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
|
| | | | | | |
| | 
Michael
W. | | erstmal richtig einrücken. da ist evtl ein "endif" zu viel. wenn ein solches auskommentiert war, dann prost... |
| | | | | | |
| |
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"
|
| | | | | | |
| | | | | | | | | |
| |
Jörg
Sellmeyer | Ich hab das Addr auch mal weggelassen, falls du das meinst. Ansonsten: was ist X11 ? |
| | | | | | |
| | 
p.specht
| Free!  |
| | | | XProfan 11Computer: Gerät, daß es in Mikrosekunden erlaubt, 50.000 Fehler zu machen, zB 'daß' statt 'das'... | 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),Win10, Win 11, Profan 6 - X4, XPSE, und 'nen schwarzes, blinkendes Dingens, wo ich das alles reinschütte... | 14.06.2018 ▲ |
| | |
|
Zum QuelltextThemenoptionen | 12.480 Betrachtungen |
ThemeninformationenDieses Thema hat 6 Teilnehmer: |
(1.732)
Deutsch
English
Français
Español
Italia