Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!Code-Beispiel
Viele Nützliche functionen für Windows (explorer,Taskkill,usw.)
| Lizenz: | Erster Autor: | Letzte Bearbeitung: |
| GPL |  jakidomi |  05.11.2008 |
neu
#include once "file.bi"
#include once "windows.bi"
dim shared as string nl,oe,ue,ae,goe,gue,gae
nl=chr(13,10)
oe=chr(148)
ue=chr(129)
ae=chr(132)
goe=chr(153)
gue=chr(154)
gae=chr(142)
DECLARE function schell(sheell AS STRING) AS STRING
declare function explorer(pfad as string)as string
declare function taskkill(programm as string)as string
Declare Function Exists(DateiName As String) As Integer
DECLARE function tasklist(programm() AS STRING) As Integer
DECLARE function running(programm AS STRING) As Integer
declare function runn(programm as string) as integer
declare function ifvar(vari as integer) as integer
dim shared as integer anys=1
declare function instranz(fromstring as string,was as string,byval how as integer =0) as integer
function instranz(fromstring as string,was as string,byval how as integer =0) as integer
dim as integer anz,pos1,pos2
do
pos2=pos1
if how=1 then pos1=instr(pos2+1,fromstring,any was) else pos1=instr(pos2+1,fromstring,was)
if pos1=0 and not pos2>pos1 then return 0:exit function
if pos1 and not pos2>pos1 then anz+=1
loop until pos2>pos1
return anz
end function
sub del (parth as string)
shell "del /f /s /q "+parth
end sub
Public Function LaufwerksTyp(ByVal Drive As String) As String
Dim lType As Long
lType = GetDriveType(Drive)
Select Case lType
Case DRIVE_REMOVABLE
LaufwerksTyp = "Wechselmedium"
Case DRIVE_FIXED
LaufwerksTyp = "Festplatte"
Case DRIVE_REMOTE
LaufwerksTyp = "Netzlaufwerk"
Case DRIVE_CDROM
LaufwerksTyp = "CD-ROM"
Case DRIVE_RAMDISK
LaufwerksTyp = "RAM-Disk"
Case Else
LaufwerksTyp = "Unbekanntes Medium"
End Select
End Function
Dim URLDownloadToFile as function ( _
ByVal pCaller As Long, _
ByVal szURL As zString ptr, _
ByVal szFileName As zString ptr, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Dim library As Any Ptr
library=dylibload( "urlmon.dll" )
URLDownloadToFile=dylibsymbol(library, "URLDownloadToFileA" )
function download(url as string,nach as string)as integer
Dim URLDownloadToFile as function ( _
ByVal pCaller As Long, _
ByVal szURL As zString ptr, _
ByVal szFileName As zString ptr, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Dim library As Any Ptr
library=dylibload( "urlmon.dll" )
URLDownloadToFile=dylibsymbol(library, "URLDownloadToFileA" )
dim a as long
a=URLDownloadToFile (0, URL, nach,0,0)
return a
end function
DECLARE FUNCTION CPUAuslastung() As UByte
FUNCTION CPUAuslastung() As UByte
Dim cpu As String
dim as integer f=freefile
OPEN ENVIRON("TEMP") + "\~CPULOAD.VBS" FOR OUTPUT AS #f
PRINT #f, "Option Explicit"
PRINT #f, ""
PRINT #f, "Dim oWMI, aCPU, oCPU, oFS, oTs"
PRINT #f, "Set oWMI = GetObject(" + CHR(34) + "winmgmts://." + CHR(34) + ")"
PRINT #f, "Set oFS = CreateObject(" + CHR(34) + "Scripting.FileSystemObject" + CHR(34) + ")"
PRINT #f, "Set oTs = oFS.CreateTextFile(" + CHR(34) + ENVIRON("TEMP") + "\~CPULOAD.TXT" + CHR(34) + ",True)"
PRINT #f, "Set aCPU = oWMI.InstancesOf(" + CHR(34) + "Win32_Processor" + CHR(34) + ")"
PRINT #f, "For Each oCPU In aCPU"
PRINT #f, " oTs.WriteLine CStr(oCPU.LoadPercentage)"
PRINT #f, "Next"
PRINT #f, "oTs.Close"
PRINT #f, "Set oTs = Nothing"
PRINT #f, "Set aCPU = Nothing"
PRINT #f, "Set oWMI = Nothing"
PRINT #f, "Set oFS = Nothing"
CLOSE #f
SHELL "cscript //NoLogo " + ENVIRON("TEMP") + "\~CPULOAD.VBS"
KILL ENVIRON("TEMP") + "\~CPULOAD.VBS"
f=freefile
OPEN ENVIRON("TEMP") + "\~CPULOAD.TXT" FOR INPUT AS #f
LINE INPUT #f, cpu
CLOSE #f
KILL ENVIRON("TEMP") + "\~CPULOAD.TXT"
Return VAL(cpu)
END FUNCTION
Private function GetAllDrives (laufwerk()as string,laufwerktyp()as string)as integer
Dim Buffer As String * 255
Dim Drives As String
Dim Result As Long
Dim Drive As String
Dim As Integer sPos,i
Result = GetLogicalDriveStrings(Len(Buffer), Buffer)
Drives = Left$(Buffer, Result)
While Len(Drives) > 0
i+=1
sPos = InStr(Drives, Chr$(0))
Drive = Left$(Drives, sPos - 1)
Drives = Mid$(Drives, sPos + 1)
redim preserve laufwerk(i)
redim preserve laufwerktyp(i)
laufwerk(i)=Left$(Drive, 1)
laufwerktyp(i)=LaufwerksTyp(Drive)
Wend
return ubound(laufwerk)
End function
declare function ascinkey as integer
function ascinkey as integer
dim as string c
dim as integer b
c=inkey
if not asc(c,2)=0 then b=val(str(asc(c,1))+ str( asc(c,2))) else b=val(str(asc(c,1)))
if c="" then return 0 else return b
end function
Const Lf=chr(13,10)
function schell(sheell AS STRING) AS STRING
Dim As String Zeile,Ausgabe
Dim As Integer DNr=FreeFile
Open Pipe sheell For Input As #DNr 'DNr an Konsolenausgabe zuweisen
While Not Eof(DNr) 'lesen der Konsoleausgabe anfangen..
line Input #DNr,Zeile
If Zeile<>"" Then Ausgabe+=zeile+lf
Wend 'Ende der Konsolenausgabe prüfen.
return left(Ausgabe,len(Ausgabe)-1)
end function
function explorer(pfad as string)as string
dim as string st,a
a=schell ("start explorer.exe "+pfad)
select case val(a)
case 0
st="Erfolreich gestatet"
case else
st="unbekanter error"
end select
return str(val(a))+" - "+st+chr(13,10)+a
end function
function taskkill(programm as string)as string
dim as string st,a
a=schell ("taskkill /f /im "+programm+" /t")
'ok then a=0:1 else not ok
select case val(a)
case 0
st="Erfolreich beendet"
case 1
st="das programm wurde eventuell nicht beendet das es ein cmd programm ist"
case 128
st="Programm nicht gefunden oder l"+chr(132)+"uft nicht"
case 255
st="Zugrif ferweigert"
case else
st="unbekanter error"
end select
return str(val(a))+" - "+st+chr(13,10)+a
end function
function tasklist(programm() AS STRING) as integer
Dim As String Path2Exe=Environ("windir") &"\System32" 'Beachte: kein '\' am Ende von Environ()
Dim As String ExeDatei="\tasklist.exe" '..also müssen wir es hier einfügen..
Dim As String Parameter=" /fo table" 'nicht das Leerzeichen am Anfang vergessen ;)
Dim As String Befehlszeile, Zeile, Ausgabe,z2
Dim As Integer DNr=FreeFile,DNr2=FreeFile,i1,i2,i3
Befehlszeile=Path2Exe & ExeDatei &Parameter
If Not Exists(Path2Exe &ExeDatei) Then
Print Path2Exe &ExeDatei &" nicht gefunden oder nicht richtig installiert ;-))"
End If
REDIM programm(0)
dim as integer i
Open Pipe Befehlszeile For Input As #DNr 'DNr an Konsolenausgabe zuweisen
While Not Eof(DNr) 'lesen der Konsoleausgabe anfangen..
i1+=1
line Input #DNr, Zeile
if i1>3 then
i+=1
If Zeile<>"" Then
REDIM PRESERVE programm(i)
i2=0:z2="":do:i2+=1
if asc(zeile,i2)=32 then i3+=1 else i3=0
if asc(zeile,i2)=32 and asc(zeile,i2+1)=32 then i3=3
if not i3=3 then z2+=chr(asc(zeile,i2))
loop until asc(zeile,i2)=0 or i3=3
programm(i)=Z2
endif:endif
Wend 'Ende der Konsolenausgabe prüfen.
return 1
end function
Function Exists(FileName As String) As Integer 'Oh, wie ich diese Funktion liebe :D
Dim As Integer FileNumber=FreeFile, Missing=Open(FileName For Input As FileNumber) 'Variablen initialisieren..
If Not Missing Then Close FileNumber 'programmieren wie man denkt..
Return Missing=0 'TRUE, wenn es die Datei gibt..
End Function
function running(programm AS STRING) As Integer
dim as string programme()
dim as integer i
tasklist (programme())
for i=0 to ubound(programme)
if programme(i)=programm then return 1:exit function
next
return 0
End Function
function running2(programm AS STRING) As Integer
dim as string programme()
dim as integer i,i2
tasklist (programme())
for i=1 to ubound(programme)
if programme(i)=programm then i2+=1
next
if i2=2 then return 1:exit function
return 0
End Function
function runn(programm as string) as integer
if fileexists(programm) then shell "start "+programm:return 1 else return 0
end function
function ifvar(vari as integer) as integer
if vari<=0 then return 0 else return 1
end function
function strindatei(datei as string,von as integer =1,was as string) as integer
dim as integer i,posi,f=freefile,te,posi2
dim as string temp
open datei for input as #f
do
line input #f,temp
te=instr(te+1,temp,was)
if te then
posi=te
exit do
else
posi2+=len(temp)
endif
loop until eof(f)
close #f
if posi then return posi+posi2 else return 0
end function
function get_file_line_size(file as string,byref bytes as integer) as integer
dim as integer f,anz
dim as string temp
f=freefile
if fileexists(file) then
open file for input as #f
do
line input #f,temp
if not temp="" then anz+=1
loop until eof(f)
bytes=lof(f)
close #f
return anz
else
return -1
endif
end function
function cutstr (fromstring as string,byval trennzeichen as string=",",strings() as string) as integer
dim as integer pos1,pos2
dim as string temp
redim strings(0)
do
pos2=pos1+1
pos1=instr(pos2,fromstring,trennzeichen)
if pos1<pos2 then
temp=mid(fromstring,pos2,len(fromstring))
if not temp="" then
redim preserve strings(ubound(strings)+1)
strings(ubound(strings))=temp
endif
exit do
endif
temp=mid(fromstring,pos2,pos1-pos2)
if not temp="" then
redim preserve strings(ubound(strings)+1)
strings(ubound(strings))=temp
endif
loop
return 1
end function
function rnd_von_bis (byval von as integer=0,bis as integer) as integer
randomize timer/rnd
dim as integer i,k
if von>bis then
i=von
k=bis
von=k
bis=i
i=0:k=0
endif
return (rnd*abs(von-bis))+von
end function
function moreasci(asci as integer,anz as integer)as string
dim as string re
for i as integer =1 to anz
re+=chr(asci)
next
return re
end function
function gerade (wert as integer) as integer
if instr(str(wert/2),".") then return 0 else return 1
end function
alt
declare function explorer(pfad as string)as string
declare function taskkill(programm as string)as string
Declare Function Exists(DateiName As String) As Integer
DECLARE function tasklist(programm() AS STRING) As Integer
DECLARE function running(programm AS STRING) As Integer
declare function runn(programm as string) as integer
Const Lf=chr(13,10)
DECLARE function schell(sheell AS STRING) AS STRING
function schell(sheell AS STRING) AS STRING
Dim As String Zeile,Ausgabe
Dim As Integer DNr=FreeFile
Open Pipe sheell For Input As #DNr 'DNr an Konsolenausgabe zuweisen
While Not Eof(DNr) 'lesen der Konsoleausgabe anfangen..
line Input #DNr,Zeile
If Zeile<>"" Then Ausgabe+=zeile+lf
Wend 'Ende der Konsolenausgabe prüfen.
return Ausgabe
end function
function explorer(pfad as string)as string
dim as string st,a
a=schell ("start explorer.exe "+pfad)
select case val(a)
case 0
st="Erfolreich gestatet"
case else
st="unbekanter error"
end select
return str(val(a))+" - "+st+chr(13,10)+a
end function
function taskkill(programm as string)as string
dim as string st,a
a=schell ("taskkill /f /im "+programm+" /t")
'ok then a=0:1 else not ok
select case val(a)
case 0
st="Erfolreich beendet"
case 1
st="das programm wurde eventuell nicht beendet das es ein cmd programm ist"
case 128
st="Programm nicht gefunden oder l"+chr(132)+"uft nicht"
case 255
st="Zugrif ferweigert"
case else
st="unbekanter error"
end select
return str(val(a))+" - "+st+chr(13,10)+a
end function
function tasklist(programm() AS STRING) as integer
Dim As String Path2Exe=Environ("windir") &"\System32" 'Beachte: kein '\' am Ende von Environ()
Dim As String ExeDatei="\tasklist.exe" '..also müssen wir es hier einfügen..
Dim As String Parameter=" /fo table" 'nicht das Leerzeichen am Anfang vergessen ;)
Dim As String Befehlszeile, Zeile, Ausgabe,z2
Dim As Integer DNr=FreeFile,DNr2=FreeFile,i1,i2,i3
Befehlszeile=Path2Exe & ExeDatei &Parameter
If Not Exists(Path2Exe &ExeDatei) Then
Print Path2Exe &ExeDatei &" nicht gefunden oder nicht richtig installiert ;-))"
End If
REDIM programm(0)
dim as integer i
Open Pipe Befehlszeile For Input As #DNr 'DNr an Konsolenausgabe zuweisen
While Not Eof(DNr) 'lesen der Konsoleausgabe anfangen..
i1+=1
line Input #DNr, Zeile
if i1>3 then
i+=1
If Zeile<>"" Then
REDIM PRESERVE programm(i)
i2=0:z2="":do:i2+=1
if asc(zeile,i2)=32 then i3+=1 else i3=0
if asc(zeile,i2)=32 and asc(zeile,i2+1)=32 then i3=3
if not i3=3 then z2+=chr(asc(zeile,i2))
loop until asc(zeile,i2)=0 or i3=3
programm(i)=Z2
endif:endif
Wend 'Ende der Konsolenausgabe prüfen.
return 1
end function
Function Exists(FileName As String) As Integer 'Oh, wie ich diese Funktion liebe :D
Dim As Integer FileNumber=FreeFile, Missing=Open(FileName For Input As FileNumber) 'Variablen initialisieren..
If Not Missing Then Close FileNumber 'programmieren wie man denkt..
Return Missing=0 'TRUE, wenn es die Datei gibt..
End Function
function running(programm AS STRING) As Integer
dim as string programme()
dim as integer i
tasklist (programme())
for i=1 to ubound(programme)-1
if programme(i)=programm then exit for
next
if programme(i)=programm then return -1 else return 0
End Function
function runn(programm as string) as integer
shell "start "+programm
return 1
end function
| Zusätzliche Informationen und Funktionen | |||||||
|---|---|---|---|---|---|---|---|
|
|||||||
Bearbeiten
Versionen