PINGA.PRG - By Rochinha

[kapiaba]

Boa tarde Rochinha, esta funcção deveria retornar a hora de Brasilia?

Compilei com xHarbour e fwh13.06 e não está retornando nada.

Origem: http://www.pctoledo.com.br/forum/viewtopic.php?f=4&t=14691&start=30

#include "FiveWin.ch" 

#include "dll.ch" 


static xdll // Need to TdWebService Class


STATIC oWnd


Function Main(_ping_) 

 Pinga( _ping_ )

 return nil


//-------------------------------------

Function Pinga(DestinationAddress)

//-------------------------------------

 local IcmpHandle,Replicas

 local RequestData:="Testando ping",;

    RequestSize:=15,;

    RequestOptions:="",;

    ReplyBuffer:=space(278),;

    ReplySize:=278,;

    Timeout:=500 && Milisegundos de espera

 default DestinationAddress := "0.0.0.0"

 DestinationAddress:=left(alltrim(DestinationAddress)+space(15),15)

 IcmpHandle:=IcmpCreateFile()

 Replicas:=IcmpSendEcho(IcmpHandle,;

             inet_addr(DestinationAddress),;

             RequestData,;

             RequestSize,0,;

             ReplyBuffer,;

             ReplySize,;

             Timeout)

 IcmpCloseHandle(IcmpHandle)


 CursorWait()


 // Resultados

 nInetAddr      := inet_addr(DestinationAddress)

 cNetName       := NETNAME()

 cgetHostName     := getHostName() //, Valtype( getHostName() )

 cgetNetCardID    := getNetCardID()


 cIPExtern := getIPExtern( "http://www.5volution.com.br/meuip.asp" ) // http://localhost/5volution/meuip.asp" ) // "http://www.dnsstuff.com/docs/ipall" )


 WsaStartUp() // Very Important


 cgetHostByName_NetName:= getHostByName( NETNAME() )

 cgetHostByAddress_IP := getHostByAddress( DestinationAddress )

 cgetHostByName_Google := getHostByName( "www.google.com" )


 WsaCleanUp() // Very Important


 ? "function inet_addr: " + str(inet_addr(DestinationAddress)),;

  "function NetName: " + cNetName,;

  "function getHostName: " + cgetHostName,;

  "function getNetCardID: " + cgetNetCardID,;

  "function getHostByName with NetName: " + cgetHostByName_NetName,;

  "function getHostByAddress with IP: " + cgetHostByAddress_IP,;

  "function getHostByName with Google site: " + cgetHostByName_Google,; 

  "function getPIExtern in my website: " + cIPExtern,;

  "function getComputerName: " + getComputerName(),;

  "function getUserDomain: " + getUserDomain(),;

  "function getUserName: " + getUserName(),;

  "function getEnvironmentString: " + getEnvironmentString( "%windir%" ),;

  "function CreateShortcut" + CreateShortcut( "c:\5volution", "nfwh29.exe", "c:\5volution\5volution.lnk" )


 if Replicas > 0

   msginfo("Machine "+alltrim(DestinationAddress)+" exist")

 else

   msginfo("Machine "+alltrim(DestinationAddress)+" not existe")

 endif


 DEFINE WINDOW oWnd TITLE "Servidor: " + cNetName

     DEFINE BUTTONBAR oBar OF oWnd _3D

     //DEFINE BUTTON OF oBar ACTION Server() TOOLTIP "Listen"

 ACTIVATE WINDOW oWnd ON INIT ProcessPage( "http://www.5volution.com.br/app01.asp" )


 CleanHTML( "http://www.5volution.com.br/app01.asp" )


 //ProcessPage( "http://www.dnsstuff.com/docs/ipall" )


 //CleanHTML( "http://www.dnsstuff.com/docs/ipall" )


 DEFINE WINDOW oWnd TITLE "Local IP"


 ACTIVATE WINDOW oWnd ;

   ON INIT MsgInfo( getHostByName( NETNAME() ) ) // GetIP() )


 return nil


//---------------------------------------------------- 

//DLL32 FUNCTION SndPlaySound( cFile AS LPSTR, nType AS WORD ) AS BOOL PASCAL LIB "MMSYSTEM.DLL" 

//---------------------------------------------------- 

DLL32 FUNCTION RSProcess(npID AS LONG ,nMode AS LONG ) AS LONG FROM "RegisterServiceProcess" LIB "kernel32.DLL" 

DLL32 FUNCTION GCP() AS LONG FROM "GetCurrentProcessId" LIB "kernel32.dll" 


// DLL32 STATIC FUNCTION FISAVE( nFormat AS LONG, hDib AS LONG, cFileName AS LPSTR, nFlags AS LONG ) AS BOOL PASCAL FROM "_FreeImage_Save@16" LIB hLib


//---------------------------------------------------- 

DLL32 FUNCTION WSAGetLastError() AS _INT PASCAL FROM "WSAGetLastError" LIB "wsock32.dll"

DLL32 FUNCTION inet_addr(cIP AS STRING) AS LONG PASCAL FROM "inet_addr" LIB "wsock32.dll"

DLL32 FUNCTION IcmpCreateFile() AS LONG PASCAL FROM "IcmpCreateFile" LIB "icmp.dll"

DLL32 FUNCTION IcmpCloseHandle(IcmpHandle AS LONG) AS LONG PASCAL FROM "IcmpCloseHandle" LIB "icmp.dll"

DLL32 FUNCTION IcmpSendEcho(IcmpHandle AS LONG,;

              DestinationAddress AS LONG,;

              RequestData AS STRING,;

              RequestSize AS LONG,;

              RequestOptions AS LONG,;

              ReplyBuffer AS LPSTR,;

              ReplySize AS LONG,;

              Timeout AS LONG) AS LONG PASCAL FROM "IcmpSendEcho" LIB "icmp.dll"


function getIPExtern( _site_ )

 local _IPExtern_

 ws:=TdWebService():new()

 _IPExtern_ := ws:OpenWS( _site_ )

 ws:end()

 return _IPExtern_


function getUserDomain()

 LOCAL reg

 oNetwork := TOleAuto():New("wscript.Network")

 return oNetwork:UserDomain()


function getUserName()

 LOCAL reg

 oNetwork := TOleAuto():New("wscript.Network")

 return oNetwork:UserName()


function getComputerName()

 LOCAL reg

 oNetwork := TOleAuto():New("wscript.Network")

 return oNetwork:ComputerName()


function getEnvironmentString( _string_ )

 LOCAL reg

 oWSHShell := TOleAuto():New("wscript.Shell")

 return oWSHShell:ExpandEnvironmentStrings( _string_ )


function CreateShortcut( _sPath_, _sFile_, _sTitle_ )

 LOCAL reg

 //oWSHShell := TOleAuto():New("wscript.Shell")

 //oMyShortcut := oWSHShell:CreateShortcut( _sTitle_ )

 //// Definir as propriedades do objeto atalho e salvá-las

 //oMyShortcut:TargetPath   := oWSHShell:ExpandEnvironmentStrings( _sPath_ + "\" + _sTitle_ )

 //oMyShortcut:WorkingDirectory := oWSHShell:ExpandEnvironmentStrings( _sPath_ )

 //oMyShortcut:WindowStyle   := 4

 ////oMyShortcut:IconLocation  := oWSHShell:ExpandEnvironmentStrings( [_sPath_] + [\] + _sTitle_+ [, 0] )

 //oMyShortcut:Save()

 return ""


//----------------------------------------------------

#include "fivewin.ch"

#include "dll.ch"


//static xdll


CLASS TdWebService

  DATA hOpen

  DATA sbuffer HIDDEN

  DATA xDLL HIDDEN

  METHOD New(buffersize) CONSTRUCTOR

  METHOD OpenWS(url)

  METHOD End()

ENDCLASS


METHOD New(conexion,buffersize) CLASS TdWebService

 DEFAULT buffersize:=64000

 ::sbuffer:=buffersize

 xDll:=LoadLib32("wininet.dll")

 ::hOpen = InternetOpen("TdWebService", 1,,, 0)

 RETURN Self


METHOD OpenWS(url) CLASS TdWebService

 local hFile,ret,xml

 hFile = InternetOpenUrl(::hOpen, url,"",0,,0)

 xml:=space(::sbuffer)

 InternetReadFile(hFile, @xml, ::sbuffer, @Ret)

 return alltrim(xml)

 //return subst(alltrim(xml),1,len(alltrim(xml))-5)


METHOD End() CLASS TdWebService

 FreeLib32(xDll)

 return nil


FUNCTION ProcessPage( cURL ) 

 local oWeb 

 local cHTML:="" // contains HTML code 

 local cSite:="" 

 local cPage:="" 

 if left(upper(cURL),7) = "HTTP://" 

   cURL:= right(cURL,len(cURL)-7) 

 endif 

 cSite:= left(cURL, at("/",cURL)-1 ) 

 cPage:= right(cURL,len(cURL)-at("/",cURL)) 

 oWeb := TWebClient():New() 

 oWeb:oSocket:Cargo := .f. // FALSE 

 oWeb:bOnConnect  := {|oWClient| oWClient:oSocket:Cargo := .t.} 

 oWeb:bOnRead   := {|cData| if(valtype(cData) == "C", cHTML += cData, )} 

 oWeb:Connect(cSite) 

 do while ! oWeb:oSocket:Cargo 

   WaitMessage()

   SysRefresh() 

 enddo 

 oWeb:GetPage( cPage ) 

 // Assign function to process code 

 oWeb:oSocket:bClose = {|self| ::end(), self:=Nil, Process(cHTML) } 

 //oWeb:oSocket:close() 

 sysrefresh() 

 return nil 


FUNCTION Process( cHTML )

 memowrit( "temp.txt", cHTML )

 return nil 


FUNCTION CleanHTML( cfile )

  LOCAL oExplorer := TOLEAuto():New( "InternetExplorer.Application" ) 

  oExplorer:Navigate2( cfile ) 

  DO WHILE oExplorer:ReadyState <> 4 

   HB_IDLESLEEP( 1 ) 

  ENDDO

  cINNText := oExplorer:Document:Body:InnerText 

  MemoWrit( "t.txt", cINNText )

  MemoEdit( MemoRead( "t.txt" ) )

  MemoEdit( cINNText )

  //? MemoRead( "t.txt" ) 

  oExplorer:Quit() 

  RETURN NIL


DLL32 FUNCTION InternetOpen( cApp as LPSTR, n1 AS DWORD, n2 AS LPSTR, n3 AS LPSTR,;

              n4 AS DWORD ) AS LONG PASCAL ;

              FROM "InternetOpenA" LIB xDll

Dll32 FUNCTION InternetReadFile(hFile As 7, @sBuffer As 8, lNumBytesToRead As 7, @lNumberOfBytesRead As 7) As 7 PASCAL Lib xDll

Dll32 FUNCTION InternetOpenUrl(hInternetSession As 7, lpszUrl As 8, lpszHeaders As 8, dwHeadersLength As 7, dwFlags As 7, dwContext As 7) As 7 FROM "InternetOpenUrlA" PASCAL Lib xDll

DLL32 FUNCTION InternetCloseHandle( hSession AS LONG ) AS BOOL PASCAL LIB xDll

DLL32 FUNCTION InternetConnect( hInternet AS LONG, cServerName AS LPSTR, nServerPort AS LONG, cUserName AS LPSTR, cPassword AS LPSTR, nService AS DWORD, nFlags AS DWORD, @nContext AS PTR ) AS LONG PASCAL FROM "InternetConnectA" LIB xDll

DLL32 FUNCTION FTPGETFILE( hConnect AS LONG, cRemoteFile AS LPSTR, cNewFile AS LPSTR, nFailIfExists AS LONG, nFlagsAndAttribs AS DWORD, nFlags AS DWORD, @nContext AS PTR ) AS BOOL PASCAL FROM "FtpGetFileA" LIB xDll

DLL32 FUNCTION FTPPUTFILE( hConnect AS LONG, cLocalFile AS LPSTR, cNewRemoteFile AS LPSTR, nFlags AS DWORD, @nContext AS PTR ) AS BOOL PASCAL FROM "FtpPutFileA" LIB xDll

DLL32 FUNCTION InternetWriteFile( hFile AS LONG, cBuffer AS LPSTR, lSize AS LONG, @nSize AS PTR ) AS BOOL PASCAL LIB xDll

DLL32 FUNCTION FtpOpenFile( hFTP AS LONG, cRemoteFile AS LPSTR, n1 AS LONG, n2 AS LONG, n3 AS LONG ) AS LONG PASCAL FROM "FtpOpenFileA" LIB xDll

DLL32 FUNCTION InternetSetFilePointer( hFile AS LONG, nDistanceToMove AS LONG, nReserved AS LPSTR, nSeekMethod AS LONG, @nContext AS PTR ) AS BOOL PASCAL LIB xDll

DLL32 FUNCTION FtpFindFirstFile( hFTP AS LONG, cMask AS LPSTR, @cWin32DataInfo AS LPSTR, n1 AS LONG, n2 AS LONG ) AS LONG PASCAL FROM "FtpFindFirstFileA" LIB xDll

DLL32 FUNCTION InternetFindNextFile( hFTPDir AS LONG, @cWin32DataInfo AS LPSTR ) AS BOOL PASCAL FROM "InternetFindNextFileA" LIB xDll

[vagner]

Kapi, pelo que ví (muito por cima), essa função é somente para verificar se o IP ou Ulr existe, ele deveria retornar o número do ip,

Eu tenho uma que pega a hora de um site, mas como sempre não consigo postar nada aqui, e para digitar demora muito, então qq coisa me chame.

[rochinha]

Amiguinhos,

Na verdade este código é um teste para retornar numeros que necessitamos em nossos aplicativos como IP, HOST, MAC, etc.

Eu compilo com Harbour 45.0 Flex.