vfp_roaauto/COMUN/utile/web/wwxmlhttp.prg

#DEFINE FLAG_ICC_FORCE_CONNECTION 0x01
*!*	http://www.mfinante.ro/contribuabili/link.jsp?body=/cod.do
*!*	cod=1879855
Clear 
SET PROCEDURE TO D:\ROA_RB\ROACONT\COMUN\PROGRAME\OPROCEDURI_COMUNE.PRG ADDITIVE 
LOCAL lcResponse, lnResponse, loMyXMLHTTP

loHTTP = CREATEOBJECT("Microsoft.XMLHTTP")
loHTTP.OPEN("POST", [http://www.mfinante.ro/contribuabili/link.jsp?body=/cod.do], .F.)
loHTTP.setRequestHeader('Content-Type', 'application/x-www-form-urlencoded')

lcValues = "cod=18798551"
loHTTP.SEND(lcValues)

lnStatus = loHTTP.STATUS
lcResponse =  UPPER(loHTTP.responseText)

lnLinii = ALines(laLines,lcResponse)

lcDenumire = laLines[670]
lnPos1 = Rat('>',lcDenumire,3)
lnPos2 = Rat('<',lcDenumire,2)
lcDenumire = Substr(lcDenumire, lnPos1 + 1, lnPos2 - lnPos1 - 1)
*MessageBox(lcDenumire)
*!*	MESSAGEBOX(lnStatus )
*!*	 NU EXISTA AGENT ECONOMIC CU ACEST COD
	STRTOFILE(lcResponse,"c:\test.htm")
	OPEN_DEFAULT_APP("c:\test.htm")

DEFINE CLASS myXMLHTTP AS CUSTOM

	oHTTP = NULL

	cHost = ""
	nError = 0
	cError = ""

	PROCEDURE INIT
		LPARAMETERS tcHost
		IF PCOUNT() = 1 AND TYPE('tcHost') = 'C' AND !EMPTY(tcHost)
			THIS.cHost = tcHost
		ENDIF
*!*			THIS.oHTTP = CREATEOBJECT("Microsoft.XMLHTTP")
		THIS.oHTTP = CREATEOBJECT("MSXML2.ServerXMLHTTP")

	ENDPROC && init

	FUNCTION CHECK_INTERNET

		DECLARE INTEGER InternetCheckConnection IN wininet ;
			STRING lpszUrlSTRING, INTEGER dwFlags, INTEGER dwReserved

		myHost = THIS.cHost

		RETURN InternetCheckConnection(myHost,FLAG_ICC_FORCE_CONNECTION,0)
	ENDFUNC && CHECK_INTERNET

	FUNCTION post
		LPARAMETERS tcValues, tcResponse

		LOCAL lcValues, loHTTP, lcResponse, lnResponse
		LOCAL llAsincron
		llAsincron = .T.
		lnResponse = 1
		tcResponse = ""
		lcResponse = ""
		IF .F.
			* NU MAI VERIFIC CONEXIUNEA LA INTERNET - DACA ROUTERUL NU ARE INTERNET STA 21 SECUNDE SA VERIFICE :(
			* POSTEZ EROAREA ASINCRON - DACA ARE INTERNET O TRIMITE
			lnCheckInternet = THIS.CHECK_INTERNET()
			IF lnCheckInternet <= 0
				RETURN
			ENDIF
		ENDIF 	
		IF EMPTY(THIS.cHost)
			RETURN
		ENDIF
		IF TYPE('this.oHTTP') = "O"
			loHTTP = THIS.oHTTP
			lcHost= THIS.cHost

			loHTTP.OPEN("POST", lcHost, llAsincron)
			loHTTP.setRequestHeader('Content-Type', 'application/x-www-form-urlencoded')

			lcValues = tcValues
			loHTTP.SEND(lcValues)

			IF .F.
				*!* DACA FOLOSESC XMLHTTP ASINCRON TREBUIE SA ASTEPT READYSTATE = 4 IN DO WHILE
				lnStatus = loHTTP.STATUS
				tcResponse =  UPPER(loHTTP.responseText)
				lnResponse = IIF('SUCCES'$tcResponse,1,-1)
			ENDIF 
		ENDIF

		RETURN lnResponse

	ENDFUNC && post

	FUNCTION postError
		LPARAMETERS tcErrorMsg, tcUserName, tcProgram, tcVersion, tcDatabaseUser

		LOCAL lcValues, lcError, lcUserName, lcProgram, lnResponse, lcVersion, lcDatabaseUser
		LOCAL laVersion
		DIMENSION laVersion[12]

		lcError = ALLTRIM(TRANSFORM(tcErrorMsg))
		lcUserName = ALLTRIM(TRANSFORM(tcUserName))
		lcProgram = ALLTRIM(TRANSFORM(tcProgram))

		IF EMPTY(tcVersion) OR TYPE('tcVersion') <> 'C'
			lnVersion = AGETFILEVERSION(laVersion, SYS(16,0))
			IF lnVersion >= 4
				lcVersion = laVersion[4]
			ELSE
				lcVersion = ""
			ENDIF
		ELSE
			lcVersion = ALLTRIM(tcVersion)
		ENDIF

		IF EMPTY(tcDatabaseUser) OR TYPE('tcDataBaseUser') <> 'C'
*!*	modificare	ROASTART	v 2.0.29
*!*				lcDatabaseUser = IIF(TYPE('gcs') = 'C', gcS, "")
			lcDatabaseUser = IIF(TYPE('gcs') = 'C', gcS, IIF(TYPE('gcHost') = 'C',gcHost, ""))
*!*	modificare	ROASTART	v 2.0.29	^
		ELSE
			lcDatabaseUser = tcDatabaseUser
		ENDIF

		lcError = THIS.urlencode(lcError)

		lcValues = "error[errormsg]=" + lcError + "&error[username]=" + lcUserName + "&error[program]=" + lcProgram + ;
			"&error[version]=" + lcVersion + "&error[databaseuser]=" + lcDatabaseUser

		lnResponse = THIS.post(lcValues)

		RETURN lnResponse

	ENDFUNC && postError

	PROCEDURE ERROR
		LPARAMETERS nError,cMethod,nLine

		lcErrorMsg=MESSAGE()+CHR(13)+CHR(13)
		lcErrorMsg=lcErrorMsg+"Method:    "+cMethod
		lcCodeLineMsg=MESSAGE(1)
		IF BETWEEN(nLine,1,10000) AND NOT lcCodeLineMsg="..."
			lcErrorMsg=lcErrorMsg+CHR(13)+"Line:         "+ALLTRIM(STR(nLine))
			IF NOT EMPTY(lcCodeLineMsg)
				lcErrorMsg=lcErrorMsg+CHR(13)+CHR(13)+lcCodeLineMsg
			ENDIF
		ENDIF

		MESSAGEBOX(lcErrorMsg)

	ENDPROC && error

	FUNCTION urlencode
		*
		* from http://www.tek-tips.com/gviewthread.cfm/lev2/4/lev3/27/pid/184/qid/597112
		* also http://fox.wikis.com/wc.dll?Wiki~VFPPortListener~VFP
		* I'm confused by this code.
		* I believe it doesn't translate spaces correctly
		*
		* a proper definition is in: http://www.ietf.org/rfc/rfc2396.txt
		* starting about half way down page 5
		* unreserved characters include all alphas, all digits and the following unreserved marks
		* mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | "(" | ")"
		*
		LPARAMETER pcinstr
		* ' encode Percent signs
		* ' Double Quotes
		* ' CarriageReturn / LineFeeds
		LOCAL lcout, lni
		lcout = ''
		FOR lni = 1 TO LEN(pcinstr)
			lcch = SUBSTR(pcinstr,lni,1)
			DO CASE
				CASE ISALPHA(lcch) OR ISDIGIT(lcch) OR INLIST(lcch, "-" , "_" , "." , "!" , "~" , "*" , "'" , "(" , ")")
					* do nothing
				CASE lcch = " "
					lcch = "+"
				OTHERWISE
					lcch = '%' + RIGHT( TRANSFORM(ASC(lcch),'@0'), 2 )
			ENDCASE
			lcout = lcout + lcch
		ENDFOR
		RETURN lcout
	ENDFUNC && UrlEncode

ENDDEFINE