PureBoard

Code: Alles auswählen

; English forum: http://purebasic.myforums.net/viewtopic.php?t=7338&highlight=
; Author: TerryHough
; Date: 16. September 2003


;PING2 - Sep 08, 2003 - Terry Hough based on work by 
;  1) PING by Siegfried Rings (known as the 'CodeGuru' ), 
;  2) URLtoIPAddress by PWS32 (from German forum), and 
;  3) LocalHostName by AlphaSnd (Fred) on main forum. 
; 
;PING2 is a Windows GUI version of the DOS based PING available on 
;Windows systems usually located as \WINDOWS\PING.EXE. PING2 add a 
;Windows interface and slightly extends the capabilites, yet remains 
;about 50 percent smaller. 
; 
;Plan to add an Error code interpretation in the future as time permits. 
; 

Global Dim bytes.w(4) 
Global Dim PingResult.w(6) 
Global Dim ttls.b(4) 
; 
Global PacketCount.w 
Global RecdPackets.w 
Global LostPackets.w 
Global LostPercent.f 
Global CheckOut.s 
Global message.s 
Global Command$
Global TheIPAddress.s 
Global MsgLen.b 
Global AvgTrip.f     : AvgTrip = 0 
Global MaxTrip.w     : MaxTrip = 0 
Global MinTrip.w     : MinTrip = 0 
; 
Declare lngNewAddress(strAdd.s) 
Declare Ping(strAdd.s) 
Declare.s GetIPbyName(NameIP.s) 
Declare.w Minimum(a.w,b1.w) 
Declare.w Maximum(a.w,b1.w) 
Declare GoDoIt(CheckStr.s) 
; 
If Not InitNetwork()
    MessageRequester("InitNetwork()", "Can't initialize the network !", #PB_MessageRequester_Ok|#MB_ICONSTOP)     
    End
EndIf
Command$ = "" 
Command$ = LCase(ProgramParameter()) 
If Len(Command$)>0 
  If Asc(Mid(Command$,1,1)) < 48 Or Asc(Mid(Command$,1,1)) > 57 
    url$ = Command$                     ; This is a URL instead of an IP Address, eg. www.google.com 
    IP$ = "" 
  Else 
    IP$ = Command$                      ; This is an IP Address in a string 
    url$ = "" 
  EndIf    
EndIf 

If OpenWindow(0, 1, 1, 600, 409, "PING2", #PB_Window_WindowCentered|#PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_TitleBar) 
  HideWindow(0,1) 
  CreateGadgetList(WindowID(0)) 
  TextGadget(1, 10, 30,160, 20, "Enter a URL", #PB_Text_Right) 
  StringGadget(2, 180, 30, 300, 20, url$) 
  TextGadget(1, 490, 30, 60, 20, "or") 
  TextGadget(1, 10, 60,160, 20, "Enter an IP Address", #PB_Text_Right) 
  IPAddressGadget(4, 180, 60, 150, 20) 
  If Len(IP$) 
    Field1.w = Val(StringField(IP$, 1, ".")) 
    Field2.w = Val(StringField(IP$, 2, ".")) 
    Field3.w = Val(StringField(IP$, 3, ".")) 
    Field4.w = Val(StringField(IP$, 4, ".")) 
    SetGadgetState(4,MakeIPAddress(Field1,Field2,Field3,Field4)) 
  EndIf    
  ButtonGadget(6, 270, 90, 60, 30, "Proceed") 
  SetActiveGadget(2) 
  While WindowEvent():Wend 
EndIf 
  ; ---------------- This is the main processing loop ---------------------- 
  If Len(Command$) 
    GoDoIt(CheckOut) 
    End                                 ; End it if running with a command tail 
  EndIf 

  HideWindow(0,0)    
  Repeat 
    EventID = WaitWindowEvent() 
      
    ; ------------------ Process the gadget events ------------------------- 

    Select EventGadget() 
        Case 6    ; Proceed button chosen 
        GoDoIt(CheckOut) 
        
    EndSelect 
      
    If EventID =  #WM_CLOSE ;  #PB_EventCloseWindow 
      Quit = 1      
    EndIf 

  ; ------------ Insure changes are saved when quit received --------------- 
  If Quit = 1 
  EndIf  

  Until Quit = 1 
  ; -------------------End of the main processing loop --------------------- 

; --------------------------------------------------------------------- 
; End of Main program code 
; --------------------------------------------------------------------- 

; Procedures 
Procedure lngNewAddress(strAdd.s) 
  sDummy.s=strAdd 
  Position = FindString(sDummy, ".",1) 
  If Position>0 
    a1=Val(Left(sDummy,Position-1)) 
    sDummy=Right(sDummy,Len(sDummy)-Position) 
    Position = FindString(sDummy, ".",1) 
    If Position>0 
      A2=Val(Left(sDummy,Position-1)) 
      sDummy=Right(sDummy,Len(sDummy)-Position) 
      Position = FindString(sDummy, ".",1) 
      If Position>0 
        A3=Val(Left(sDummy,Position-1)) 
        sDummy=Right(sDummy,Len(sDummy)-Position) 
        A4=Val(sDummy) 
        dummy.l=0 
        PokeB(@dummy,a1) 
        PokeB(@dummy+1,A2) 
        PokeB(@dummy+2,A3) 
        PokeB(@dummy+3,A4) 
        ProcedureReturn dummy 
      EndIf 
    EndIf 
  EndIf 
EndProcedure 

Procedure Ping(strAdd.s) 
  #PING_TIMEOUT = 1000
  lngHPort.l 
  lngDAddress.l 
  strMessage.s 
  lngResult.l 
  ECHO.ICMP_ECHO_REPLY 
  
  PacketCount=0
  LostPackets=0
  RecdPackets=0
  PingResult(0)=0
  
  strMessage.s = "Echo This Information Back To Me" 
  MsgLen = Len(strMessage) 
  message.s="Pinging "+CheckOut 
  If Asc(Mid(strAdd,1,1)) < 48 Or Asc(Mid(strAdd,1,1)) > 57 
    ; This is a URL instead of an IP Address, eg. www.google.com 
    GetIPbyName(strAdd)                 ; Get the IP Address for the URL 
    If Asc(Mid(TheIPAddress,1,1)) < 58  ; If successful, convert to numeric 
      lngDAddress = lngNewAddress(TheIPAddress) 
      message.s= message + " ["+TheIPAddress+"] with " 
    EndIf    
  Else 
    ; This is an IP Address in a string 
    TheIPAddress = strAdd 
    lngDAddress = lngNewAddress(strAdd) ; Convert to a numeric 
    message.s = message + " with " 
  EndIf    
  If TheIPAddress = "The Network can't be initialized." 
    message = message + Chr(10) + Chr(10) + TheIPAddress 
  ElseIf TheIPAddress = "A non-IP address was returned." 
    message = message + Chr(10) + Chr(10) + TheIPAddress 
  ElseIf TheIPAddress = "Unable to resolve domain name" 
    message = message + Chr(10) + Chr(10) + TheIPAddress 
  Else  
  lngHPort = IcmpCreateFile_() 

  message = message + Str(MsgLen)+" bytes of data:"+Chr(10)+Chr(10) 
  *buffer=AllocateMemory(SizeOf(ICMP_ECHO_REPLY)+MsgLen)
  For i = 1 To 4 
    PacketCount+1 
    lngResult = IcmpSendEcho_(lngHPort, lngDAddress, @strMessage, MsgLen , #Null,*buffer, SizeOf(ICMP_ECHO_REPLY)+MsgLen,#PING_TIMEOUT) 

    If lngResult = 0 
      message=message + "Reply from "+TheIPAddress+":  " 
      message= message + "Error no: "+ StrQ(GetLastError_()) + Chr(10) 
      PingResult(i) = -1 
      LostPackets+1 
    Else 
      CopyMemory(*buffer,@ECHO,SizeOf(ICMP_ECHO_REPLY))
      PingResult(i) = ECHO\RoundTripTime 
      bytes(i) = ECHO\DataSize 
      ttls(i) =  ECHO\Options 
      RemoteIP.s = IPString(ECHO\Address) 
      message=message + "Reply from "+RemoteIP+":  bytes = "+Str(bytes(i))+" time = "+Str(PingResult(i))+"ms TTL = "+StrU(ttls(i),#Byte)+Chr(10) 
      RecdPackets+1 
      SuccessTrip+1 
    EndIf 
    Delay(100) 
  Next 
  FreeMemory(*buffer)
  message=message + Chr(10) + "Ping statistics for "+CheckOut+":"+Chr(10) 
  message=message + "   Packets: Sent = " + Str(PacketCount) 
  message=message + ", Received = " + Str(RecdPackets) 
  message=message + ", Lost = " + Str(LostPackets) 
  If LostPackets = 0 
    LostPercent = 0 
  Else 
    LostPercent = (LostPackets/PacketCount)*100 
  EndIf 
  message=message + " ("+StrF(LostPercent,0)+"% loss)"+Chr(10)+Chr(10) 
  PingResult(5)=255 
  PingResult(6)=0 
  For i = 1 To 4 
    If PingResult(i)> 0 
      PingResult(6) = Maximum(PingResult(6),PingResult(i)) 
      PingResult(5) = Minimum(PingResult(5),PingResult(i)) 
      PingResult(0)+PingResult(i) 
    EndIf 
  Next 
  MinTrip = PingResult(5) 
  MaxTrip = PingResult(6) 
  If RecdPackets 
    AvgTrip = PingResult(0)/RecdPackets 
  Else 
    AvgTrip = PingResult(6) 
  EndIf 
  If AvgTrip > 0 
    message=message + "Approximate round trip times in milli-seconds:"+Chr(10) 
    message=message + "    Minimum = "+Str(MinTrip)+"ms,  Maximum = "+Str(MaxTrip)+",  Average = "+StrF(AvgTrip,2)+"ms" 
  EndIf 
  lngResult = IcmpCloseHandle_(lngHPort) 
  ProcedureReturn PingResult 
EndIf 
EndProcedure 

Procedure.s GetIPbyName(NameIP.s) 
  TheIPAddress.s 
    pHostinfo = gethostbyname_(NameIP) 
    If pHostinfo = 0 
      TheIPAddress = "Unable to resolve domain name" 
     Else 
      CopyMemory (pHostinfo, hostinfo.HOSTENT, SizeOf(HOSTENT)) 
      If hostinfo\h_addrtype <> #AF_INET 
        TheIPAddress = "A non-IP address was returned." 
      Else 
        While PeekL(hostinfo\h_addr_list+AdressNumber*4) 
          ipAddress = PeekL(hostinfo\h_addr_list+AdressNumber*4) 
          TheIPAddress = StrU(PeekB(ipAddress),0)+"."+StrU(PeekB(ipAddress+1),0)+"."+StrU(PeekB(ipAddress+2),0)+"."+StrU(PeekB(ipAddress+3),0) 
          AdressNumber+1 
        Wend 
      EndIf 
    EndIf 
  ProcedureReturn TheIPAddress 
EndProcedure 

Procedure.w Minimum(a.w,b1.w) 
  If a < b1 
    c1.w = a 
  Else 
    c1.w = b1 
  EndIf 
  ProcedureReturn c1 
EndProcedure 

Procedure.w Maximum(a.w,b1.w) 
  If a > b1 
    c1 = a 
  Else 
    c1 = b1 
  EndIf 
  ProcedureReturn c1 
EndProcedure 

Procedure GoDoIt(CheckStr.s) 
  CheckOut = GetGadgetText(2) 
  CheckOut = RemoveString(CheckOut, "http://") 
  CheckOut = RemoveString(CheckOut, "ftp://") 
  If Len(CheckOut)  
    Ping(CheckOut) 
  Else 
    CheckOut.s = GetGadgetText(4) 
    Ping(CheckOut) 
  EndIf    
  MessageRequester("PING2", message, #MB_ICONINFORMATION) 
  ;SetGadgetText(2,"") 
  ;SetGadgetText(4,"") 
  SetActiveGadget(2) 
EndProcedure 

; ExecutableFormat=Windows
; FirstLine=1
; EnableXP
; EOF

Code: Alles auswählen

; English forum:
; Author: Berikco
; Date: 22. September 2002


; HTTP file download
; 09/22/2002
; By Berikco
; v1.1
;
Global filenaam$

; zum Beispiel:
; http://mesh.dl.sourceforge.net/sourceforge/sevenzip/7z442.exe
server$="mesh.dl.sourceforge.net"
Port = 80
url$="/sourceforge/sevenzip/"
filenaam$="7z442.exe"

If InitNetwork() = 0
  MessageRequester("Error", "Can't initialize the network !", 0)
  End
EndIf

#bufferlengte=10240
Global Buffer
Buffer = AllocateMemory(#bufferlengte) 
Global buf$
Global EOL$
EOL$ = Chr(13)+Chr(10)

Global Size
Global oldsize
Global rate
Global ratetel
Global buf$
Global Header
Global startReceive
Global hwnd
Global ConnectionID
Global filesize
Global timeout
Global aniwin
Global h
Global einde
;
h=LoadLibrary_("Shell32.dll") 

Procedure incoming(result)
  b.b=0
  b$=""
  rest=0
  Select Header
  Case 0
    SendMessage_(aniwin,#ACM_OPEN,h,160) 
    i=0
    
    Repeat
      If PeekB(Buffer+i)=13 And PeekB(Buffer+i+1)=10 And PeekB(Buffer+i+2)=13 And PeekB(Buffer+i+3)=10
        b$=Space(i+4)
        CopyMemory(Buffer,@b$,i+4)
        rest=i+4
        Break 
      EndIf
      i+1
    Until i=result
    If i=result
        b$=EOL$
        startReceive=1
    EndIf
    ;
    Repeat
        ;
        If Left(b$,2)=EOL$
            b$=Mid(b$,3,Len(b$)-3)
            If startReceive=1
                If CreateFile(1,filenaam$)
                    WriteData(1,Buffer+rest, result-rest)
                    Header=1
                    Size=result-rest
                    SetGadgetText(4,"Received "+Str(Size)+" of "+Str(filesize)+" bytes")
                Else
                    Header=2
                EndIf     
                Break
            EndIf
        Else
            search=FindString(b$, EOL$ , 1)
            If search>0
                l$=Left(b$,search-1) 
                b$=Mid(b$,search+2,Len(b$))
                pos=FindString(l$,"200 " , 1) 
                If pos
                    startReceive=1  ; ok
                Else
                    pos=FindString(l$,"404 " , 1) 
                    If pos
                        ;error 404 not founf
                    Else
                        pos=FindString(LCase(l$),"content-length:" , 1) 
                        If pos
                            pos=FindString(l$," " , 1) 
                            filesize=Val(Mid(l$,pos+1,Len(l$)))
                        EndIf
                    EndIf
                EndIf
                Debug l$
            Else
                l$=""
                b$=EOL$
                search=1
                startReceive=1
            EndIf
        EndIf ;
    Until search=0
  Case 1
    timeout=0
    WriteData(1,Buffer, result)
    Size+result
    If filesize
        FileSize$=Str(filesize)
        stap=100*Size/filesize
    Else
        FileSize$="??"
        stap=0
    EndIf
    SetGadgetText(4,"Received "+Str(Size)+" of "+Str(filesize)+" bytes")
    SetGadgetState(2, stap)
    If filesize=Size
      Debug "File Received"
      Header=2
      Debug Str(Size)+" of "+Str(filesize)+" bytes"
    EndIf  
  Case 2
    CloseFile(1)
    CloseNetworkConnection(ConnectionID)
    Debug "Connection Closed"
    Header=3
    DestroyWindow_(aniwin)
    einde=1
  EndSelect
EndProcedure
;
Procedure MyWindowCallback(WindowID, message, wParam, lParam) 
  result = #PB_ProcessPureBasicEvents 
  Select WindowID
  Case hwnd
    Select message
    Case #WM_TIMER 
      result=0
      Select wParam
      Case 1 ; timer
        result=ReceiveNetworkData(ConnectionID, Buffer, #bufferlengte)
        If result=0
            filesize=Size
        EndIf
        incoming(result)
      Case 2  ; timeout
        timeout+1
        If timeout>10
          CloseFile(1)
          Header=2
          Debug "Timeout"     
        EndIf
      Case 3
        ratetel+500
        If ratetel>0
          rate=Size/ratetel
        EndIf
        SetGadgetText(3,"Download speed..."+Str(rate)+" KB/s.  Time "+Str(ratetel/1000)+" s.") 
      EndSelect
    EndSelect
  EndSelect
  ProcedureReturn result 
EndProcedure 
;
hwnd=OpenWindow(0,100,450,335,160,"Downloading "+filenaam$+" from "+server$,#PB_Window_SystemMenu)
;
If hwnd
  If CreateGadgetList(WindowID(0))
    ButtonGadget(1, 250, 128,  72, 20, "Cancel")
    ProgressBarGadget(2, 10, 100, 313, 20, 0, 100)
    TextGadget(3, 20, 80,  280, 15, "")
    TextGadget(4, 20, 65,  280, 15, "")
    ;
    aniwin=CreateWindowEx_(0,"SysAnimate32","",#ACS_AUTOPLAY|#ACS_CENTER|#ACS_TRANSPARENT|#WS_CHILD|#WS_VISIBLE|#WS_CLIPCHILDREN|#WS_CLIPSIBLINGS,25,10,280,50, hwnd,0,GetModuleHandle_(0),0)
    ;
    ConnectionID = OpenNetworkConnection(server$, Port)
    ;
    If ConnectionID
      SendNetworkString(ConnectionID, "GET "+url$+filenaam$+" HTTP/1.0"+EOL$)
      SendNetworkString(ConnectionID, "Host: "+server$+EOL$)
      SendNetworkString(ConnectionID, "Accept: */*"+EOL$)
      SendNetworkString(ConnectionID, EOL$)
    ;
    SetWindowCallback(@MyWindowCallback()) 
    ; -------------- timers ----------------
    SetTimer_(hwnd,1,20,0) ; 20 milisecond timer
    SetTimer_(hwnd,2,1000,0) ; 1 sec timer
    SetTimer_(hwnd,3,500,0) ; 500 msec timer    
    ;
    Repeat
      EventID=WaitWindowEvent() 
        Select EventGadget()
        Case 1
            Header=2
        EndSelect
    Until einde=1
    EndIf
  EndIf
EndIf
FreeLibrary_(h)
Delay(4000)
;
End
; ExecutableFormat=
; CursorPosition=4
; FirstLine=1
; EOF

Code: Alles auswählen

; English forum: http://purebasic.myforums.net/viewtopic.php?t=6719
; Author: eddy (updated for PB3.93 by ts-soft)
; Date: 25. June 2003

;- Procedure-Code
Global WINDOW_Requester
; ///////////////////// 
; Set position 
; ///////////////////// 


Procedure SetRequesterPosition(x,y,ParentWin) 
  ;create the invisible window which defines the position of requester 
  If WINDOW_Requester = 0
    WINDOW_Requester =  OpenWindow(#PB_Any,x,y,0,0,"Temp Hidden Window",#PB_Window_BorderLess,WindowID(ParentWin)) 
  EndIf 
  
  If WindowID(WINDOW_Requester)        
    ResizeWindow(WINDOW_Requester,x,y,#PB_Ignore,#PB_Ignore)    
  EndIf 
EndProcedure  


;- Example-Code
GetCursorPos_(@pt.POINT) 
SetRequesterPosition(pt\x,pt\y,ParentWin) 
c = ColorRequester() 

; ExecutableFormat=Windows
; FirstLine=1
; EOF

Code: Alles auswählen

; German forum:
; Author: CyberRun8 
; Date: 03. April 2003

;Beispiel von CyberRun8 
;für PureBasic 3.62 
;März 2003 

;-Konstanten setzen 
#Window = 0 

#Gadget1 = 0 
#Gadget2 = 1 
#Gadget3 = 2 

;-Fenster mit Gadgets darstellen 
If OpenWindow(#Window, 100, 150, 240, 90, "AdvancedGadgetEvents", #PB_Window_MinimizeGadget) 
  If CreateGadgetList(WindowID(#Window)) 
    ;AdvancedGadgetEvents(#True) ; <---- 
    ButtonGadget(#Gadget1, 5, 5, 230, 20, "Doppelklick-Button") 
    ButtonGadget(#Gadget2, 5, 35, 230, 20, "Einfachklick-Button") 
    ;AdvancedGadgetEvents(#False); <---- 
    ButtonGadget(#Gadget3, 5, 65, 230, 20, "Gadget ohne Advanced-Funktion") 
  EndIf 
EndIf 

Debug "Focusangabe:" 
;-Schleife 
Repeat 
  EventID.l = WaitWindowEvent() 
  
  If EventID = #PB_Event_Gadget    
    Select EventGadget() 
      Case #Gadget1 
        If EventType() = #PB_EventType_Focus 
          Debug "Focus auf Doppelklick-Button gesetzt"                
        ElseIf EventType() = #PB_EventType_LeftDoubleClick 
          MessageRequester("Info", "Linksdoppelklick", 0) 
        ElseIf EventType() = #PB_EventType_RightDoubleClick 
          MessageRequester("Info", "Rechtsdoppelklick", 0)              
        EndIf 
      Case #Gadget2 
        If EventType() = #PB_EventType_LeftClick          
          MessageRequester("Info", "Linksklick auf Einfachklick-Button", 0) 
        ElseIf EventType() = #PB_EventType_RightClick          
          MessageRequester("Info", "Rechtsklick auf Einfachklick-Button", 0) 
        ElseIf EventType() = #PB_EventType_Focus 
          Debug "Focus auf Einfachklick-Button gesetzt" 
        EndIf 
      Case #Gadget3 
        ;Folgende Abfrage ist ohne Funkton weil für Gadget3 die fortgeschrittene Ereignisangabe 
        ;abgeschaltet wurde. 
        If EventType() = #PB_EventType_Focus 
          Debug "Focus auf Doppelklick-Button gesetzt"                
        ElseIf EventType() = #PB_EventType_LeftDoubleClick 
          MessageRequester("Info", "Linksdoppelklick", 0) 
        ElseIf EventType() = #PB_EventType_RightDoubleClick 
          MessageRequester("Info", "Rechtsdoppelklick", 0)              
        EndIf          
    EndSelect 
  EndIf        
Until EventID = #PB_Event_CloseWindow 
End

Code: Alles auswählen

;English forum: http://purebasic.myforums.net/viewtopic.php?t=6719
; Author: eddy (updated for PB3.93 by ts-soft)
; Date: 25. June 2003

;- Procedure-Code
Global WINDOW_Requester
; /////////////////////
; Set position
; /////////////////////

ParentWin=OpenWindow(#PB_Any,100,100,500,500,"Test Window")

Procedure SetRequesterPosition(x,y,ParentWin)
  ;create the invisible window which defines the position of requester
  If WINDOW_Requester = 0
    WINDOW_Requester =  OpenWindow(#PB_Any,x,y,0,0,"Temp Hidden Window",#PB_Window_BorderLess,WindowID(ParentWin))
  EndIf
 
  If WindowID(WINDOW_Requester)       
    ResizeWindow(WINDOW_Requester,x,y,#PB_Ignore,#PB_Ignore)   
  EndIf
EndProcedure 


;- Example-Code
GetCursorPos_(@pt.POINT)
SetRequesterPosition(pt\x,pt\y,ParentWin)
c = ColorRequester()

; ExecutableFormat=Windows
; FirstLine=1
; EOF 

Code: Alles auswählen

; English forum: http://purebasic.myforums.net/viewtopic.php?t=6719
; Author: eddy (updated for PB3.93 by ts-soft)
; Date: 25. June 2003

;- Procedure-Code
Global WINDOW_Requester
; ///////////////////// 
; Set position 
; ///////////////////// 

Procedure SetRequesterPosition(x,y, ParentID=#PB_Ignore) 
  ;create the invisible window which defines the position of requester 
  If WINDOW_Requester = 0
    If ParentID=#PB_Ignore
      WINDOW_Requester =  OpenWindow(#PB_Any,x,y,0,0,"Temp Hidden Window",#PB_Window_BorderLess|#PB_Window_Invisible)
    Else
      WINDOW_Requester =  OpenWindow(#PB_Any,x,y,0,0,"Temp Hidden Window",#PB_Window_BorderLess|#PB_Window_Invisible,ParentID) 
    EndIf
  EndIf 
  
  If WindowID(WINDOW_Requester)
    ResizeWindow(WINDOW_Requester,x,y,#PB_Ignore,#PB_Ignore)
  EndIf 
EndProcedure  


;- Example-Code
GetCursorPos_(@pt.POINT)
SetRequesterPosition(pt\x,pt\y)
c = ColorRequester()

; ExecutableFormat=Windows
; FirstLine=1
; EOF