Cálculo Online Encomendas Correios

[jrcardozo 4]

Acabo de criar, bom proveito

<%
Option Explicit
Sub calcularFreteCorreios(servico, cepOrigem, cepDestino, peso, valorDeclarado, maoPropria, avisoRecebimento, ByRef valor, ByRef uf, ByRef localidade, ByRef tarifa)
	'SEDEX						= 40010
	'SEDEX à Cobrar		=	40045
	'SEDEX 10					=	40215
	'PAC							= 41017	
	If Not IsNumeric(servico) Then
		Select Case Ucase(servico)
			Case "SEDEX"			 : servico = "40010"
			Case "SEDEX10"		: servico = "40215"
			Case "SEDEXCOBRAR": servico = "40045"
			Case "PAC"				 :	servico = "41017"
			Case Else 
				Response.Write _ 
					"É necessário definir o serviço."
				Response.End()
		End Select
	End If
	
	cepOrigem = Replace(cepOrigem & "", "-", "")
	cepOrigem = Replace(cepOrigem, "/", "")
	cepOrigem = Replace(cepOrigem, ".", "")

	cepDestino = Replace(cepDestino & "", "-", "")
	cepDestino = Replace(cepDestino, "/", "")
	cepDestino = Replace(cepDestino, ".", "")

	If Not IsNumeric(cepOrigem) Or Len(cepOrigem) < 8 Then	
		Response.Write _
			"CEP de origem não é válido."
		Response.End()
	End If
	
	If Not IsNumeric(cepDestino) Or Len(cepDestino) < 8 Then	
		Response.Write _
			"CEP de destino não é válido."
		Response.End()
	End If
	
	valorDeclarado = Replace(valorDeclarado & "", ".", "")
	If Not IsNumeric(valorDeclarado) Then
		Response.Write _
			"Valor declarado é inválido."
		Response.End()
	End If
	
	peso = Replace(peso & "", ".", "")
	peso = Replace(peso & "", ",", ".")
	If Not IsNumeric(peso) Then
		Response.Write _
			"Peso é inválido."
		Response.End()
	End If

	maoPropria			 = UCase(maoPropria & "")
	If maoPropria <> "N" And maoPropria <> "S" Then
		Response.Write _
			"Mão Própria inválida."
		Response.End()
	End If
	
	avisoRecebimento = UCase(avisoRecebimento & "")
	If avisoRecebimento <> "N" And avisoRecebimento <> "S" Then
		Response.Write _
			"Aviso de Recebimento inválido."
		Response.End()
	End If

	Dim urlCorreios
	Dim XMLHttp
	Dim objXML
	Dim resposta
	DIM objErro
	Dim objPreco
	Dim objLocal
	Dim objTarifa

	urlCorreios = ""&_
		"http://www.correios.com.br/encomendas/precos/calculo.cfm?"&_
		"resposta=xml&"&_
		"servico=" & servico & "&"& _
		"cepOrigem=" & cepOrigem & "&"&_
		"cepDestino=" & cepDestino & "&"&_
		"peso=" & peso & "&"&_
		"MaoPropria=" & maoPropria & "&"&_
		"valorDeclarado=" & valorDeclarado & "&"&_
		"avisoRecebimento=" & avisoRecebimento & ""
	Set XMLHttp = Server.CreateObject("MSXML2.ServerXMLHTTP")		
	XMLHttp.setOption 2, 13056
	XMLHttp.Open "POST", urlCorreios, False
	XMLHttp.send()
	Set objXML = Server.CreateObject("Microsoft.XMLDOM")
	objXML.async = True
	objXML.load(XMLHttp.responseBody)	
	If CStr(objXML.parseError.errorCode) <> "0" Then
		valor = -1
	Else
		Set objErro = objXML.getElementsByTagName("erro")
		If CStr(objErro.item(0).text <> "0") Then
			valor = -1
		Else
			Set objPreco	= objXML.getElementsByTagName("preco_postal")			
			valor				 = objPreco.item(0).text			
			Set objLocal	= objXML.getElementsByTagName("uf_destino")			
			uf						= objLocal.item(0).text
			Set objLocal	= objXML.getElementsByTagName("local_destino")
			localidade		= objLocal.item(0).text			
			Set objTarifa	= objXML.getElementsByTagName("tarifa_valor_declarado")
			tarifa				= objTarifa.item(0).text
			Set objTarifa = Nothing
			Set objPreco	 = Nothing
			Set objLocal	 = Nothing
		End If
		Set objErro = Nothing
	End If
	Set XMLHttp = Nothing
	Set objXML	 = Nothing
End Sub

Dim valor
Dim uf
Dim localidade
Dim tarifa

Call calcularFreteCorreios ("PAC", "91910530", "91910530", "3", "10", "N", "N", valor, uf, localidade, tarifa)

response.Write "Valor Tarifa Seguro: R$ " & tarifa & "<br />"
response.Write "Valor Encomenda: R$ " & valor & "<br />"
response.Write "UF/Localidade: " & uf & "/" & localidade
%>

[Ted k' 126]

o bom e velho DOM, esse gaúcho!!

 

vou testar rapa!! he!

[hargon 64]

Muito bom gaúcho.

 

http://forum.imasters.com.br/public/style_emoticons/default/clap.gif

[Patrique 0]

How.... exelente cara, muito útil este script! exelente!

 

Valew!

 

[]'s

[jrcardozo 4]

obrigado pelo apoio galera

 

quem precisar de auxilio na utilização é só recorrer postando aqui

 

[]