Buchempfehlung
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
"Der" Petzold, das über 1000 Seiten starke Standardwerk zum Win32-API - besonders nützlich u. a. bei der GUI-Programmierung in FreeBASIC! [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

Code-Beispiel

Code-Beispiele » Windows GUI

Viele Nützliche functionen für Windows (explorer,Taskkill,usw.)

Lizenz:Erster Autor:Letzte Bearbeitung:
GPLMitgliedjakidomi 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
  • Das Code-Beispiel wurde am 17.08.2008 von Mitgliedjakidomi angelegt.
  • Die aktuellste Version wurde am 05.11.2008 von Mitgliedjakidomi gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen