I am trying to upload a csv file then read it line by line and pass it to my Database. I have a issue on file upload I could see that whenever I upload a file an extra number gets added to a column in my csv and due to this my code fails. I could see that the file gets saved in the expected location and when I opened it I could see an extra number which I never added. What could be the reason for this?
Here is my code for uploading the CSV file and reading it and using a loop I'm iterating the values in the csv file and storing the values in my variables which is then passed to a method to store in DB.
<HTML>
<HEAD>
<!--#include file="clsUpload.asp"-->
<!-- #include file = "Bin/includes/GenFunctions.asp" -->
<!-- #include file = "Bin/includes/HeaderFooter.asp" -->
</HEAD>
<title>CMTL Entry File Upload</title>
<%showHeader%>
<BODY text="#000000" leftmargin="0" topmargin="0" marginwidth="0" marginheight="0">
<FORM ACTION = "clsUploadtest.asp" ENCTYPE="multipart/form-data" METHOD="POST">
File Name: <INPUT TYPE=FILE NAME="txtFile"><P>
<INPUT TYPE = "SUBMIT" NAME="cmdSubmit" VALUE="SUBMIT">
</FORM><P>
<%
'Declare the form variables
Dim intRecordId
Dim strRecordId
Dim strAction
Dim strInputDate
Dim strPayer
Dim strAmount
Dim strTransType
Dim strPayee
Dim strAddRemarks
Dim strComments
Dim strAccNo
Dim strPolicyNo
Dim strBranchConfDate
Dim strConfBy
Dim strSheetUpdDate
Dim strMailUpdDate
Dim strUploadTime
Dim strUploadId
Dim strStatus
Dim strLastMdfdDate
Dim strLastMdfdId
Dim lineData
Dim code
Dim name
Dim mail
Dim id
Dim price
Dim amount
Dim MyArray
Dim i
i = 0
set obj = Server.CreateObject("AC_FI.mMTL")
If err.number <> 0 Then
RaiseGenError objCMTL,"Error while creating the object "
Response.End
end if
set o = new clsUpload
if o.Exists("cmdSubmit") then
'get client file name without path
sFileSplit = split(o.FileNameOf("txtFile"), "\")
sFile = sFileSplit(Ubound(sFileSplit))
o.FileInputName = "txtFile"
o.FileFullPath = Server.MapPath(".") & "\entry\" & sFile
o.save
if o.Error = "" then
response.write "Success. File saved to " & o.FileFullPath
else
response.write "Failed due to the following error: " & o.Error
end if
set fso = Server.CreateObject("Scripting.FileSystemObject")
set fs = fso.OpenTextFile(Server.MapPath("entry/" & sFile), 1, False)
Do While Not fs.AtEndOfStream
lineData = fs.ReadLine
'lineData = replace(lineData,chr(13),",")
'lineData = replace(lineData,chr(34),"")
MyArray = Split(lineData , ",")
strRecordId=MyArray(0)
strInputDate=MyArray(1)
strPayer=MyArray(2)
strAmount=MyArray(3)
strTransType=MyArray(4)
strPayee=MyArray(5)
strAddRemarks=MyArray(6)
strComments=MyArray(7)
strAccNo=MyArray(8)
strPolicyNo=MyArray(9)
strBranchConfDate=MyArray(10)
strConfBy=MyArray(11)
strSheetUpdDate=MyArray(12)
strMailUpdDate=MyArray(13)
strUploadTime=MyArray(14)
strUploadId=MyArray(15)
strStatus=MyArray(16)
strRecordId = convertNullString(strRecordId)
strAction = convertNullString(strAction)
strInputDate = convertNullDate(strInputDate)
strPayer = convertNullString(strPayer)
strAmount = convertNullString(strAmount)
strTransType = convertNullString(strTransType)
strPayee = convertNullString(strPayee)
strAddRemarks = convertNullString(strAddRemarks)
strComments = convertNullString(strComments)
strAccNo = convertNullString(strAccNo)
strPolicyNo = convertNullString(strPolicyNo)
strBranchConfDate = convertNullDate(strBranchConfDate)
strConfBy = convertNullString(strConfBy)
strSheetUpdDate = convertNullDate(strSheetUpdDate)
strMailUpdDate = convertNullDate(strMailUpdDate)
strUploadTime = convertNullDate(strUploadTime)
strUploadId = convertNullString(strUploadId)
strStatus = convertNullString(strStatus)
intRecordId = obj.InsertData(strInputDate,strPayer,strAmount,strTransType,strPayee,strAddRemarks,_
strComments,strAccNo,strPolicyNo,strBranchConfDate,strConfBy,strSheetUpdDate,_
strMailUpdDate,strUploadTime,strUploadId,strStatus, pErrorcode)
i=i+1
Loop
fs.close()
set fs = nothing
set fso = nothing
end if
set o = nothing
%>
<%showFooter%>
</BODY>
</HTML>
this is the clsupload.asp file that I have used for file upload
<%
' ------------------------------------------------------------------------------
' Container of Field Properties
Class clsField
Public FileName
Public ContentType
Public Value
Public FieldName
Public Length
Public BinaryData
End Class
' ------------------------------------------------------------------------------
Class clsUpload
' ------------------------------------------------------------------------------
Private nFieldCount
Private oFields()
Private psFileFullPath
Private psError
Private psFileInputName
' ------------------------------------------------------------------------------
Public Property Get Count()
Count = nFieldCount
End Property
' ------------------------------------------------------------------------------
Public Default Property Get Field(ByRef asFieldName)
Dim lnLength
Dim lnIndex
lnLength = UBound(oFields)
If IsNumeric(asFieldName) Then
If lnLength >= asFieldName And asFieldName > -1 Then
Set Field = oFields(asFieldName)
Else
Set Field = New clsField
End If
Else
For lnIndex = 0 To lnLength
If LCase(oFields(lnIndex).FieldName) = LCase(asFieldName) Then
Set Field = oFields(lnIndex)
Exit Property
End If
Next
Set Field = New clsField
End If
End Property
' ------------------------------------------------------------------------------
Public Function Exists(ByRef avKeyIndex)
Exists = Not IndexOf(avKeyIndex) = -1
End Function
' ------------------------------------------------------------------------------
Public Property Get ValueOf(ByRef avKeyIndex)
Dim lnIndex
lnIndex = IndexOf(avKeyIndex)
if lnIndex = -1 Then Exit Property
ValueOf = oFields(lnIndex).Value
End Property
' ------------------------------------------------------------------------------
Public Property Get FileNameOf(ByRef avKeyIndex)
Dim lnIndex
lnIndex = IndexOf(avKeyIndex)
if lnIndex = -1 Then Exit Property
FileNameOf = oFields(lnIndex).FileName
End Property
' ------------------------------------------------------------------------------
Public Property Get LengthOf(ByRef avKeyIndex)
Dim lnIndex
lnIndex = IndexOf(avKeyIndex)
if lnIndex = -1 Then Exit Property
LengthOf = oFields(lnIndex).Length
End Property
' ------------------------------------------------------------------------------
Public Property Get BinaryDataOf(ByRef avKeyIndex)
Dim lnIndex
lnIndex = IndexOf(avKeyIndex)
if lnIndex = -1 Then Exit Property
BinaryDataOf = oFields(lnIndex).BinaryData
End Property
' ------------------------------------------------------------------------------
Private Function IndexOf(ByVal avKeyIndex)
Dim lnIndex
If avKeyIndex = "" Then
IndexOf = -1
ElseIf IsNumeric(avKeyIndex) Then
avKeyIndex = CLng(avKeyIndex)
If nFieldCount > avKeyIndex And avKeyIndex > -1 Then
IndexOf = avKeyIndex
Else
IndexOf = -1
End If
Else
For lnIndex = 0 To nFieldCount - 1
If LCase(oFields(lnIndex).FieldName) = LCase(avKeyIndex) Then
IndexOf = lnIndex
Exit Function
End If
Next
IndexOf = -1
End If
End Function
' ------------------------------------------------------------------------------
Public Property Let FileFullPath(sValue)
psFileFullPath = sValue
End Property
'___________________________________________________________________________________
Public Property Get FileFullPath()
FileFullPath = psFileFullPath
End Property
' ------------------------------------------------------------------------------
Public Property Let FileInputName(sValue)
psFileInputName = sValue
End Property
' -------------------- ----------------------------------------------------------
Public Function Save()
if psFileFullPath <> "" and psFileInputName <> "" then
'Save to connectionless client side recordset, write to stream,
'and persist stream.
'would think you should be able to write directly to
'stream without recordset, but I could not get that to work
On error resume next
binData = o.BinaryDataOf(psFileInputName)
set rs = server.createobject("ADODB.RECORDSET")
rs.fields.append "FileName", 205, LenB(binData)
rs.open
rs.addnew
rs.fields(0).AppendChunk binData
if err.number = 0 then
set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1
objStream.Open
objStream.Write rs.fields("FileName").value
objStream.SaveToFile psFileFullPath, 2
objStream.close
set objStream = Nothing
ENd if
rs.close
set rs = nothing
psError = Err.Description
else
psError = "One or more required properties (FileFullPath and/or FileInputName) not set"
End If
End Function
Public Property Get Error()
Error = psError
End Property
' ------------------------------------------------------------------------------
Public Property Get ContentTypeOf(ByRef avKeyIndex)
Dim lnIndex
lnIndex = IndexOf(avKeyIndex)
if lnIndex = -1 Then Exit Property
ContentTypeOf = oFields(lnIndex).ContentType
End Property
' ------------------------------------------------------------------------------
Private Sub Class_Terminate()
Dim lnIndex
For lnIndex = 0 To nFieldCount - 1
Set oFields(0) = Nothing
Next
End Sub
' ------------------------------------------------------------------------------
Private Sub Class_Initialize()
Dim lnBytes ' Bytes received from the client
Dim lnByteCount ' Number of bytes received
Dim lnStartPosition ' Position at which content begins
Dim lnEndPosition ' Position at which content ends
Dim loDic ' Contains properties of each
' specific field
' Local dictionary object(s)
' to be appended to class-scope
' dictionary object.
Dim lnBoundaryBytes ' Bytes contained within the current boundary
Dim lnBoundaryStart ' Position at which the current boundary begins
' within the lnBytes binary data.
Dim lnBoundaryEnd ' Position at which the current boundary ends
' within the lnBytes binary data.
Dim lnDispositionPosition
Dim lsFieldName ' Name of the current field being parsed from
' Binary Data
Dim lsFileName ' Name of the file within the current boundary
Dim lnFileNamePosition ' Location of file name within current boundary
Dim loField ' clsField Object
Dim lsValue ' Value of the current field
Dim lsContentType ' ContentType of the binary file (MIME Type)
' Initialize Fields
nFieldCount = 0
ReDim oFields(-1)
' Read the bytes (binary data) into memory
lnByteCount = Request.TotalBytes
lnBytes = Request.BinaryRead(lnByteCount)
'Get the lnBoundaryBytes
lnStartPosition = 1
lnEndPosition = InstrB(lnStartPosition, lnBytes, CStrB(vbCr))
If lnEndPosition >= lnStartPosition Then
lnBoundaryBytes = MidB(lnBytes, lnStartPosition, lnEndPosition - lnStartPosition)
End If
lnBoundaryStart = InstrB(1, lnBytes, lnBoundaryBytes)
' Loop until the BoundaryBytes begin with "--"
Do Until (lnBoundaryStart = InstrB(lnBytes, lnBoundaryBytes & CStrB("--")))
' All data within this boundary is stored within a local dictionary
' to be appended to the class-scope dictionary.
ReDim Preserve oFields(nFieldCount)
nFieldCount = nFieldCount + 1
Set loField = New clsField
lnDispositionPosition = InstrB(lnBoundaryStart, lnBytes, CStrB("Content-Disposition"))
' Get an object name
lnStartPosition = InstrB(lnDispositionPosition, lnBytes, CStrB("name=")) + 6
lnEndPosition = InstrB(lnStartPosition, lnBytes, CStrB(""""))
lsFieldName = CStrU(MidB(lnBytes, lnStartPosition, lnEndPosition - lnStartPosition))
loField.FieldName = lsFieldName
' Get the location fo the file name.
lnFileNamePosition = InstrB(lnBoundaryStart, lnBytes, CStrB("filename="))
lnBoundaryEnd = InstrB(lnEndPosition, lnBytes, lnBoundaryBytes)
'Test if object is a file
If Not lnFileNamePosition = 0 And lnFileNamePosition < lnBoundaryEnd Then
' Parse Filename
lnStartPosition = lnFileNamePosition + 10
lnEndPosition = InstrB(lnStartPosition, lnBytes, CStrB(""""))
lsFileName = CStrU(MidB(lnBytes,lnStartPosition,lnEndPosition-lnStartPosition))
loField.FileName = lsFileName
' Parse Content-Type
lnStartPosition = InstrB(lnEndPosition,lnBytes,CStrB("Content-Type:")) + 14
lnEndPosition = InstrB(lnStartPosition,lnBytes,CStrB(vbCr))
lsContentType = CStrU(MidB(lnBytes,lnStartPosition,lnEndPosition-lnStartPosition))
loField.ContentType = lsContentType
' Parse Content
lnStartPosition = lnEndPosition + 4
lnEndPosition = InstrB(lnStartPosition,lnBytes,lnBoundaryBytes)-2
lsValue = MidB(lnBytes,lnStartPosition,lnEndPosition-lnStartPosition)
loField.BinaryData = lsValue & CStrB(vbNull)
loField.Length = LenB(lsValue)
Else
' Parse Content
lnStartPosition = InstrB(lnDispositionPosition, lnBytes, CStrB(vbCr)) + 4
lnEndPosition = InstrB(lnStartPosition, lnBytes, lnBoundaryBytes) - 2
lsValue = CStrU(MidB(lnBytes,lnStartPosition,lnEndPosition-lnStartPosition))
loField.Value = lsValue
loField.Length = Len(lsValue)
End If
Set oFields(UBound(oFields)) = loField
'Loop to next object
lnBoundaryStart = InstrB(lnBoundaryStart + LenB(lnBoundaryBytes), lnBytes, lnBoundaryBytes)
Set loField = Nothing
Loop
End Sub
' ------------------------------------------------------------------------------
Private Function CStrU(ByRef psByteString)
Dim lnLength
Dim lnPosition
lnLength = LenB(psByteString)
For lnPosition = 1 To lnLength
CStrU = CStrU & Chr(AscB(MidB(psByteString, lnPosition, 1)))
Next
End Function
' ------------------------------------------------------------------------------
Private Function CStrB(ByRef psUnicodeString)
Dim lnLength
Dim lnPosition
lnLength = Len(psUnicodeString)
For lnPosition = 1 To lnLength
CStrB = CStrB & ChrB(AscB(Mid(psUnicodeString, lnPosition, 1)))
Next
End Function
' ------------------------------------------------------------------------------
End Class
' ------------------------------------------------------------------------------
%>
You can see that the file has an extra value added in it and code fails. I have no idea from where this value comes in each time I upload the file. The file in my local machine doesn't have that value. Can anyone help?
Related
I'm using Application.FileDialog(msoFileDialogFolderPicker) to pick a folder and it handles well folders with utf8 names.
But when I try to Debug.Print the result of SelectedItems(1) or save it to a config file or do anything, I loose the accents of the folder.
For example:
Original folder:
"D:\Śākta"
'Debug.Print' or saving into an utf8 file result saves:
"D:\Sakta" (removed all the accents)
The problem is that I try to save the selected folder to a config file and when I try to load it, next time it will of course won't recognize as a real folder because of the missing accents.
How to get the real name of the folder with the accents to be able to save it after, not this "representation" of it?
Update:
Just checked, and even the InputBox kills the accents!
#John Coleman's answer solved the issue switching the file saving to 'ADODB.Stream'
Here is an example of reading and writing config file supporting UTF8:
Public Function fileExists(ByVal fullFilename As String) As Boolean
fileExists = CreateObject("Scripting.FileSystemObject").fileExists(fullFilename)
End Function
Public Function ReadTextFile(ByVal sPath As String) As String
If fileExists(sPath) Then
Dim fsT As Object
Set fsT = CreateObject("ADODB.Stream")
fsT.Mode = adModeRead
fsT.Type = 2 'Specify stream type - we want To save text/string data.
fsT.Charset = "utf-8" 'Specify charset For the source text data.
fsT.Open 'Open the stream And write binary data To the object
fsT.LoadFromFile (sPath)
ReadTextFile = fsT.ReadText
fsT.Close
Set fsT = Nothing
Else
ReadTextFile = ""
End If
End Function
Public Function WriteTextFile(ByVal s As String, ByVal sPath As String) As Boolean
Dim objStreamUTF8NoBOM: Set objStreamUTF8NoBOM = CreateObject("ADODB.Stream")
Dim fsT As Object
Set fsT = CreateObject("ADODB.Stream")
fsT.Type = 2 'Specify stream type - we want To save text/string data.
fsT.Charset = "utf-8" 'Specify charset For the source text data.
fsT.Open 'Open the stream And write binary data To the object
fsT.WriteText s
fsT.Position = 0
fsT.SaveToFile sPath, 2 'Save binary data To disk
fsT.Position = 3
With objStreamUTF8NoBOM
.Type = 1
.Open
fsT.CopyTo objStreamUTF8NoBOM
.SaveToFile sPath, 2
Close
End With
fsT.Close
Set fsT = Nothing
Set objStreamUTF8NoBOM = Nothing
End Function
Function SetSettings(ByVal Keyname As String, ByVal Wstr As String) As String
Dim settingsFileContent
settingsFileContent = ReadTextFile(IniFileName)
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = Keyname + "=.*"
RE.MultiLine = 1
If RE.Test(settingsFileContent) Then
settingsFileContent = RE.Replace(settingsFileContent, Keyname + "=" + Wstr)
Else
settingsFileContent = settingsFileContent + IIf(Len(settingsFileContent) = 0, "", vbNewLine) + Keyname + "=" + Wstr
End If
WriteTextFile settingsFileContent, IniFileName
SetSettings = Wstr
End Function
Private Function GetSettings(ByVal Keyname As String) As String
Dim settingsFileContent As String
settingsFileContent = ReadTextFile(IniFileName)
Set RE = CreateObject("VBScript.RegExp")
RE.MultiLine = 1
RE.Global = 1
RE.Pattern = "\r"
settingsFileContent = RE.Replace(settingsFileContent, "")
RE.Global = 0
RE.Pattern = "^" + Keyname + "=(.*)"
Set allMatches = RE.Execute(settingsFileContent)
If allMatches.Count <> 0 Then
Debug.Print (Keyname + ": """ + allMatches.Item(0).SubMatches.Item(0) + """")
GetSettings = allMatches.Item(0).SubMatches.Item(0)
Else
GetSettings = ""
End If
End Function
I track POD's Online. I do it from behind a proxy and use Microsoft Access in a query to execute the function to download the tracking information and parse it out. The base code is below. The function I use is TrackNew(trackingNumber). Each morning when I run this access.exe is asking for my credentials. I track from UPS and FedEx xml gateways and it doesn't ask for the proxy credentials. Is there a way that I can add the credentials inside my code so it doesn't prompt for this?
Here at the top is everything that makes this work. At the bottom is the actual function.
Private Enum HTTPequestType
HTTP_GET
HTTP_POST
HTTP_HEAD
End Enum
#If VBA7 Then
' 64-bit
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet"
(ByRef dwflags As LongPtr, _
ByVal dwReserved As Long) As Long
#Else
' pre 64-bit
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet"
(ByRef dwflags As Long, _
ByVal
dwReserved As Long) As Long
#End If
Private Const CONNECT_LAN As Long = &H2
Private Const CONNECT_MODEM As Long = &H1
Private Const CONNECT_PROXY As Long = &H4
Private Const CONNECT_OFFLINE As Long = &H20
Private Const CONNECT_CONFIGURED As Long = &H40
' Application Objects
Private xl As Access.Application
' misc symbols
Private Const CHAR_SPACE As String = " "
Private Const CHAR_UNDERSCORE As String = "_"
Private Const CHAR_COMMA As String = ","
Private Const CHAR_SLASH As String = "/"
Private Const AT_SYMBOL As String = "#"
' list of carriers (must be UPPER CASE, comma-delimited)
Private Const CARRIER_LIST As String =
"UPS,UPS1,UPS2,UPS3,UPS4,UPS5,UPS6,UPS7,UPS8,NEW,DHL,DHL1,FEDEX,FEDEX2,FEDEX3,FEDEX4,FEDEX5,HOLLAND,CONWAY,ABF,CEVA,USPS,TNT,YRCREGIONAL,YRC,NEMF,A1,RWORLDCOURIER,BLUEDART,TCIXPS,PUROLATOR,EXPINT,CMACGM,SAFM,PLG,DHL,ONTRAC,AAACT,RLC,ODFL,SAIA,DHLGLOBAL,LASERSHIP"
' MSXML stuff
Private Const MSXML_VERSION As String = "6.0"
' error Msgs
Private Const UNKNOWN_CARRIER As String = "Unknown carrier"
Private Const ERROR_MSG As String = "Error"
Private Const PACKAGE_NOT_FOUND As String = "Package Not Found"
Private Const MSIE_ERROR As String = "Cannot start Internet Explorer."
Private Const MSXML_ERROR As String = "Cannot start MSXML 6.0."
Private Const MSHTML_ERROR As String = "Cannot load MSHTML Object library."
' URLs for each carrier
Private Const NEWUrl As String = "https://www.newpenn.com/embeddable-tracking-results/?track="
'
' system functions
'
Private Function GetAppTitle() As String
GetAppTitle = App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
End Function
Private Function IsWindowsOS() As Boolean
' true if operating system is Windows
IsWindowsOS = (GetWindowsOS Like "*Win*")
End Function
'
' required addin procedures
'
Private Sub AddinInstance_OnAddInsUpdate(custom() As Variant)
' needed for operation
Exit Sub
End Sub
Private Sub AddinInstance_OnStartupComplete(custom() As Variant)
' needed for operation
Exit Sub
End Sub
' helper functions
Private Function GetRequestType(reqType As HTTPequestType) As String
Select Case reqType
Case 1
GetRequestType = "POST"
Case 2
GetRequestType = "HEAD"
Case Else ' GET is default
GetRequestType = "GET"
End Select
End Function
Private Function IsValidCarrier(CarrierName As String) As Boolean
' returns TRUE if the given carrier is on the global list
Dim carriers() As String
carriers = Split(CARRIER_LIST, ",")
IsValidCarrier = (UBound(Filter(carriers, CarrierName)) > -1)
End Function
Private Function GetHTMLAnchors(htmlDoc As Object) As Object ' MSHTML.IHTMLElementCollection
On Error Resume Next
Set GetHTMLAnchors = htmlDoc.anchors
End Function
Private Function LoadError(xmlDoc As Object) As Boolean
' checks if a xml file load error occurred
LoadError = (xmlDoc.parseError.ErrorCode <> 0)
End Function
Private Function GetRootNode(xmlDoc As Object) As Object
' returns root node
Set GetRootNode = xmlDoc.DocumentElement
End Function
Private Function GetNode(parentNode As Object, nodeNumber As Long) As Object
On Error Resume Next
' if parentNode is a MSXML2.IXMLDOMNodeList
Set GetNode = parentNode.Item(nodeNumber - 1)
' if parentNode is a MSXML2.IXMLDOMNode
If GetNode Is Nothing Then
Set GetNode = parentNode.ChildNodes(nodeNumber - 1)
End If
End Function
Private Function CreateFile(fileName As String, contents As String) As String
' creates file from string contents
Dim TempFile As String
Dim nextFileNum As Long
nextFileNum = FreeFile
TempFile = fileName
Open TempFile For Output As #nextFileNum
Print #nextFileNum, contents
Close #nextFileNum
CreateFile = TempFile
End Function
Here is where it prompts me for the windows domain credentials for the proxy.
Private Function GetResponse(xml As Object, requestType As HTTPequestType, _
destinationURL As String, Optional async As Boolean, _
Optional requestHeaders As Variant, Optional postContent As String) As String
Dim reqType As String
Dim response As String
Dim i As Long
reqType = GetRequestType(requestType)
With xml
.Open reqType, destinationURL, async
' check for headers
If Not IsMissing(requestHeaders) Then
For i = LBound(requestHeaders) To UBound(requestHeaders)
.setRequestHeader requestHeaders(i, 1), requestHeaders(i, 2)
Next i
End If
' if HTTP POST, need to send contents
' will not harm GET or HEAD requests
.Send (postContent)
' if HEAD request, return headers, not response
If reqType = "HEAD" Then
response = xml.getAllResponseHeaders
Else
response = xml.responseText
End If
End With
GetResponse = response
End Function
Private Function GetRequestHeaders() As Variant
Dim tempArray(1 To 1, 1 To 2) As Variant
tempArray(1, 1) = "Content-Type"
tempArray(1, 2) = "application/x-www-form-urlencoded"
GetRequestHeaders = tempArray
End Function
' major objects
Private Function GetMSIE() As Object ' InternetExplorer.Application
On Error Resume Next
Set GetMSIE = CreateObject("InternetExplorer.Application")
End Function
Private Function CreateHTMLDoc() As Object ' MSHTML.HTMLDocument
On Error Resume Next
Set CreateHTMLDoc = CreateObject("htmlfile")
End Function
Private Function GetMSXML() As Object ' MSXML2.XMLHTTP60
On Error Resume Next
Set GetMSXML = CreateObject("MSXML2.XMLHTTP" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
Private Function GetServerMSXML() As Object
On Error Resume Next
Set GetServerMSXML = CreateObject("MSXML2.ServerXMLHTTP" &
IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
Private Function CreateXMLDoc() As Object ' MSXML2.DOMDocument60
On Error Resume Next
Set CreateXMLDoc = CreateObject("MSXML2.DOMDocument" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
' XMLHTTP or MSIE
'''''Private Function GetMSXMLWebResponse(URL As String) As String
''''' Dim webObject As Object ' MSXML2.XMLHTTP60
''''' Set webObject = GetMSXML
''''' If webObject Is Nothing Then ' cannot start MSXML6
''''' Exit Function
''''' End If
''''' ' open URL and scrape result
''''' With webObject
''''' .Open "GET", URL, False
''''' .send
''''' End With
''''' GetMSXMLWebResponse = webObject.responseText
'''''End Function
Private Function GetMSIEWebResponse(URL As String) As String
Dim webObject As Object ' InternetExplorer.Application
Set webObject = GetMSIE
If webObject Is Nothing Then ' cannot start MSIE
Exit Function
End If
'open the url
webObject.navigate URL
'wait for the site to be ready
Do Until webObject.readyState = 4 ' READYSTATE_COMPLETE
DoEvents
Loop
'read the text from the body of the site
GetMSIEWebResponse = webObject.Document.body.innerText
webObject.Quit
End Function
Here is the actual tracking code:
Private Function TrackNEW(trackingNumber As String) As String
Dim xml As Object
Dim tempString As String
Dim htmlDoc As Object ' MSHTML.HTMLDocument
Dim htmlBody As Object ' MSHTML.htmlBody
Dim anchors As Object ' MSHTML.IHTMLElementCollection
Dim anchor As Object ' MSHTML.IHTMLElement
Dim dda As Object ' MSHTML.IHTMLElementCollection
Dim ddb As Object
Dim ddc As Object
Dim ddd As Object
Dim span As Object
Dim div As Object
Dim class As Object ' MSHTML.IHTMLElement
Set xml = GetMSXML
If xml Is Nothing Then ' cannot start MSXML 6.0
TrackNEW = MSXML_ERROR
Exit Function
End If
tempString = GetResponse(xml, HTTP_GET, NEWUrl & trackingNumber, False)
If Len(tempString) = 0 Then
MsgBox "5"
TrackNEW = ERROR_MSG
Exit Function
End If
Set htmlDoc = CreateHTMLDoc
If htmlDoc Is Nothing Then ' cannot reference MSHTML object library
MsgBox "6"
TrackNEW = MSHTML_ERROR
Exit Function
End If
On Error Resume Next
Set htmlBody = htmlDoc.body
htmlBody.innerHTML = tempString
Set dda = htmlDoc.getElementsByTagName("span")
Set ddb = htmlDoc.getElementsByTagName("span")
Set ddc = htmlDoc.getElementsByTagName("span")
Set ddd = htmlDoc.getElementsByTagName("div")
Item = 1
For Each Strg4 In ddd
For ItemNumber4 = 400 To 450
Strg4 = ddd.Item(ItemNumber4).innerText
If InStr(Strg4, "Projected Delivery Date") >= 1 Then
Why = ItemNumber4
Strg4 = ddd.Item(Why).innerText
GoTo Line8
Else
End If
Next ItemNumber4
Next Strg4
GoTo Line9
Exit Function
Line8:
TrackNEW = "INTRANSIT" & "|" & Right(Strg4, 11)
Exit Function
Line9:
Item = 1
For Each Strg In dda
For ItemNumber = 160 To 200
Strg = dda.Item(ItemNumber).innerText
If InStr(Strg, "DELIVERED") >= 1 Then
That = ItemNumber
Strg = dda.Item(That).innerText
GoTo Line2
Else
End If
Next ItemNumber
Next Strg
GoTo Line1
Line2:
Item2 = 1
For Each Strg2 In ddb
For ItemNumber2 = 160 To 200
Strg2 = ddb.Item(ItemNumber2).innerText
If InStr(Strg2, "DELIVERED") >= 1 Then
This = ItemNumber2 + 3
Strg2 = ddb.Item(This).innerText
GoTo Line3
Else
End If
Next ItemNumber2
Next Strg2
GoTo Line1
Line3:
Item3 = 1
For Each Strg3 In ddb
For ItemNumber3 = 160 To 200
Strg3 = ddb.Item(ItemNumber3).innerText
If InStr(Strg3, "DELIVERED") >= 1 Then
How = ItemNumber3 + 5
Strg3 = ddc.Item(How).innerText
GoTo Line4
Else
End If
Next ItemNumber3
Next Strg3
GoTo Line1
Line4:
TrackNEW = Strg & "|" & Strg2 & "|" & Strg3
Set xml = Nothing
Set htmlDoc = Nothing ' MSHTML.HTMLDocument
Set htmlBody = Nothing ' MSHTML.htmlBody
Set anchors = Nothing ' MSHTML.IHTMLElementCollection
Set anchor = Nothing ' MSHTML.IHTMLElement
Set dda = Nothing
Exit Function
Line1:
TrackNEW = "TRACKING|CANNOT|BE|FOUND"
Set xml = Nothing
Set htmlDoc = Nothing ' MSHTML.HTMLDocument
Set htmlBody = Nothing ' MSHTML.htmlBody
Set anchors = Nothing ' MSHTML.IHTMLElementCollection
Set anchor = Nothing ' MSHTML.IHTMLElement
Set dda = Nothing
Exit Function
End Function
Any help would be appreciated. I need the actual lines of code or reference that would get around it from prompting me for the windows credentials the proxy.
I found this snippet of code. Under the GETMSXML i could add this?
'Set GetMSXML = CreateObject("MSXML2.ServerXMLHTTP" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
'xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
'GetMSXML.setProxy 2, "proxy.website.com:8080"
'GetMSXML.setProxyCredentials "user", "password"
I have this template data
Header of file ((string1, string2...)
group1 header (string1, string2...)
group1/line1 (string1, string2...)
group1/line2 (string1, string2...)
group2 header (string1, string2...)
group2/line1 (string1, string2...)
group2/line2 (string1, string2...)
Note : The datas belonging to group header and group line are different type even if they are on the same 'coloumn' (raw data comes from text file)
I create my main class (populate collection) and data class (populate item : cData_Nomination), everything works individualy BUT I need to create :
-1 file collection (I have multiples files) which store
-- fields (file header) and
-- x sub collection (groups) wich store
--- fields (group header)
--- x sub collection which store
---- fields (line data)
In the folowing code on line 170 .oDpo is the group collection every data are store on a collection with property Let (....).
Everything seem to be store !
Public Function NomCreate(m_sFilepath As String, m_objDataList() As String, m_clDpo As Collection) As cData_Nomination
10 On Error GoTo Err_Handler
Dim Functions As New cFunctions
Dim objResult As cData_Nomination
Dim objDate() As String
'Note : Init Var(s) /Object(s)
'----------------------------
20 Set objResult = New cData_Nomination
30 With objResult
40 .FileName = Functions.String_NZ(m_sFilepath)
50 .DataSource = Functions.String_NZ(m_objDataList(1))
60 .DelRes = Functions.String_NZ(m_objDataList(2))
70 .DateTime = Functions.Date_NZ(m_objDataList(4) & " " & m_objDataList(5) & ":00")
80 objDate = Split(Replace(m_objDataList(6), " - ", "-"), "-")
90 .DateTimeRange_Start = Functions.Date_NZ(objDate(0))
100 .DateTimeRange_End = Functions.Date_NZ(objDate(1))
110 .Sender = Functions.String_NZ(m_objDataList(7))
120 .Receiver = Functions.String_NZ(m_objDataList(8))
130 .GasPointName = Functions.String_NZ(m_objDataList(9))
140 .GasPointNameExternal = Functions.String_NZ(m_objDataList(10))
150 .Description = Functions.String_NZ(m_objDataList(11))
160 .DataType = Functions.String_NZ(m_objDataList(12))
170 .oDpo = Dpo
180 End With
Err_Exit:
'Note : Return Function value
190 Set NomCreate = objResult
'Note : Delete object
200 Set objResult = Nothing
'Note : Exit
210 Exit Function
Err_Handler:
'Note : Exit Function
220 GoTo Err_Exit
When I try to read data i got a problem I can't access to the collection .oDo via property Get (see the following code)
'property belonging to class cData_Nomination
Public Property Let oDpo(ByVal oCollection As Collection)
Dim m_oDpo As New Collection
Set m_oDpo = oCollection
End Property
How can I pass collection to an existing item collection (I might have been wrong) and How can i retrieve my sub collection items from the main collection ?
I hope it's clear ...
Thanks in advance
Class cNum (Extract of parent)
Private m_sFileName As String
Private oDpo As Collection
Private Sub Class_Initialize()
Set oDpo = New Collection
End Sub
Public Property Get FileName() As String
FileName = m_sFileName
End Property
Public Property Let FileName(ByVal sFileName As String)
m_sFileName = sFileName
End Property
Public Property Get Dpo() As Collection
Set Dpo = oDpo
End Property
Public Property Set DpoAdd(DpoCollection As Collection)
Dim DpoItem
For Each DpoItem In DpoCollection
oDpo.Add DpoItem
Next
End Property
Class cDop (Child of parent)
Private m_sDelivery As String
Private oQty As Collection
Private Sub Class_Initialize()
Set oQty = New Collection
End Sub
Public Property Get Delivery() As String
Delivery = m_sDelivery
End Property
Public Property Let Delivery(ByVal sDelivery As String)
m_sDelivery = sDelivery
End Property
Public Property Get Qty() As Collection
Set Qty = oQty
End Property
Public Property Set QtyAdd(QtyCollection As Collection)
Dim QtyItem
For Each QtyItem In QtyCollection
oQty.Add QtyItem
Next
End Property
Class cQty (Sub Child)
Private m_sStatus As String
Public Property Get Status() As String
Status = m_sStatus
End Property
Public Property Let Status(ByVal sStatus As String)
m_sStatus = sStatus
End Property
Regular Module
Sub myModule()
Dim i As Long
Dim j As Long
Dim k As Long
Dim cNum As cNum
Dim cDpo As cDpo
Dim cQty As cQty
Dim oNum As Collection
Dim oDpo As Collection
Dim oQty As Collection
Set oNum = New Collection
For i = 1 To 3
Set cNum = New cNum
cNum.FileName = "File " & i
Set oDpo = New Collection
For j = 1 To 3
Set cDpo = New cDpo
cDpo.Qty = "Qty" & i & j
cDpo.Delivery = "Delivery " & i & j
Set oQty = New Collection
For k = 1 To 3
Set cQty = New cQty
cQty.Statut = "OK_" & i & "-" & j & "-" & k
oQty.Add cQty
Next k
Set cDpo.QtyAdd = oQty
oDpo.Add cDpo
Next j
Set cNum.DpoAdd = oDpo
oNum.Add cNum
Next i
'Set oDpo = Nothing
'
For Each cNum In oNum
Debug.Print ""
Debug.Print "---------FILE ----------------"
Debug.Print ""
Debug.Print "-[NUM] " & cNum.FileName & " | " & cNum.Info
Set oDpo = cNum.Dpo
For Each cDpo In oDpo
Debug.Print "--[DPO] " & cDpo.Counterpart & " | " & cDpo.Delivery
Set oQty = cDpo.Qty
For Each cQty In oQty
Debug.Print "---[QTY] " & cQty.Quantity & " | " & cQty.Statut
Next
Next
Next
End Sub
I've been stuck on this one for a few days with no progress. Using classic ASP, I need to take an uploaded .JPG file (from html form input type='file') and base64 encode it so that I can send it to a Java web service. The Java web service is simply storing the image (in a SQL image field) in a database. I figured converting to BASE64 was the best way to transfer the parameter in the xml. Here's what I have so far:
HTML:
<label>Upload Picture</label>
<input name="file" id="file" type="file" size=40 /> <br />
ASP:
Dim load
Set load = new Loader
load.initialize
Dim fileData
fileData = load.getFileData("file")
Dim fileName
fileName = LCase(load.getFileName("file"))
Dim fileSize
fileSize = load.getFileSize("file")
Dim objXML
Dim objNode
Dim strB64
Set objXML = Server.CreateObject("MSXML2.DomDocument.3.0")
Set objNode = objXML.createElement("base64")
objNode.dataType = "bin.base64" 'stores binary as base64 string
objNode.nodeTypedValue = fileData 'binary value
strB64 = objNode.Text
LOADER:
the loader is a lot of code (I can copy all of it here if needed). It essentially gets all the bytes from the request and parses them into a dictionary object. Here's how it gets the data:
Class Loader
Private dict
Private Sub Class_Initialize
Set dict = Server.CreateObject("Scripting.Dictionary")
End Sub
Public Sub Initialize
If Request.TotalBytes > 0 Then
Dim binData
binData = Request.BinaryRead(Request.TotalBytes)
getData binData
End If
End Sub
Public Function getFileData(name) '"file"
If dict.Exists(name) Then
getFileData = dict(name).Item("Value")
Else
getFileData = ""
End If
End Function
I can post the sub that parses and stores the binary in a dictionary if needed.
The above code gives this error:
msxml3.dll error '80004005'
Error parsing '????' as bin.base64 datatype.
on this line:
objNode.nodeTypedValue = fileData 'binary value
UPDATE:
Here's where the data is loaded to the dictionary:
Private Sub getData(rawData)
Dim separator
separator = MidB(rawData, 1, InstrB(1, rawData, ChrB(13)) - 1)
Dim lenSeparator
lenSeparator = LenB(separator)
Dim currentPos
currentPos = 1
Dim inStrByte
inStrByte = 1
Dim value, mValue
Dim tempValue
tempValue = ""
While inStrByte > 0
inStrByte = InStrB(currentPos, rawData, separator)
mValue = inStrByte - currentPos
If mValue > 1 Then
value = MidB(rawData, currentPos, mValue)
Dim begPos, endPos, midValue, nValue
Dim intDict
Set intDict = Server.CreateObject("Scripting.Dictionary")
begPos = 1 + InStrB(1, value, ChrB(34))
endPos = InStrB(begPos + 1, value, ChrB(34))
nValue = endPos
Dim nameN
nameN = MidB(value, begPos, endPos - begPos)
Dim nameValue, isValid
isValid = True
If InStrB(1, value, stringToByte("Content-Type")) > 1 Then
begPos = 1 + InStrB(endPos + 1, value, ChrB(34))
endPos = InStrB(begPos + 1, value, ChrB(34))
If endPos = 0 Then
endPos = begPos + 1
isValid = False
End If
midValue = MidB(value, begPos, endPos - begPos)
intDict.Add "FileName", trim(byteToString(midValue))
begPos = 14 + InStrB(endPos + 1, value, stringToByte("Content-Type:"))
endPos = InStrB(begPos, value, ChrB(13))
midValue = MidB(value, begPos, endPos - begPos)
intDict.Add "ContentType", trim(byteToString(midValue))
begPos = endPos + 4
endPos = LenB(value)
nameValue = MidB(value, begPos, ((endPos - begPos) - 1))
Else
nameValue = trim(byteToString(MidB(value, nValue + 5)))
End If
If isValid = True Then
intDict.Add "Value", nameValue
intDict.Add "Name", nameN
dict.Add byteToString(nameN), intDict
End If
End If
currentPos = lenSeparator + inStrByte
Wend
End Sub
Private Function stringToByte(toConv)
Dim tempChar, i
For i = 1 to Len(toConv)
tempChar = Mid(toConv, i, 1)
stringToByte = stringToByte & chrB(AscB(tempChar))
Next
End Function
Private Function byteToString(toConv)
dim i
For i = 1 to LenB(toConv)
byteToString = byteToString & chr(AscB(MidB(toConv,i,1)))
Next
End Function
I finally found something that works! Here's the link:
http://www.motobit.com/tips/detpg_binarytostring/
The issue I was having was that the data from the BinaryRead was multibyte data (which ASP doesn't play well with). MultiByte data must be converted To VT_UI1 | VT_ARRAY in order for the base64 encoding via the Dom Document Object (or nearly any other function - including loading to a stream). This can be achieved using an ADO recordset object as such:
Function MultiByteToBinary(MultiByte)
' 2000 Antonin Foller, http://www.motobit.com
' MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY)
' Using recordset
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
If LMultiByte>0 Then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
Hopefully this will help someone else as well.
Let ADODB.Stream do your heavy lifting, this assumes you already have saved the file to disk. These are the functions for BASE64 I use, I'm not 100% sure where I originally got them.
private function readBytes(file)
dim inStream
' ADODB stream object used
set inStream = WScript.CreateObject("ADODB.Stream")
' open with no arguments makes the stream an empty container
inStream.Open
inStream.type= TypeBinary
inStream.LoadFromFile(file)
readBytes = inStream.Read()
end function
private function encodeBase64(bytes)
dim DM, EL
Set DM = CreateObject("Microsoft.XMLDOM")
' Create temporary node with Base64 data type
Set EL = DM.createElement("tmp")
EL.DataType = "bin.base64"
' Set bytes, get encoded String
EL.NodeTypedValue = bytes
encodeBase64 = EL.Text
end function
private function decodeBase64(base64)
dim DM, EL
Set DM = CreateObject("Microsoft.XMLDOM")
' Create temporary node with Base64 data type
Set EL = DM.createElement("tmp")
EL.DataType = "bin.base64"
' Set encoded String, get bytes
EL.Text = base64
decodeBase64 = EL.NodeTypedValue
end function
private Sub writeBytes(file, bytes)
Dim binaryStream
Set binaryStream = CreateObject("ADODB.Stream")
binaryStream.Type = adTypeBinary
'Open the stream and write binary data
binaryStream.Open
binaryStream.Write bytes
'Save binary data to disk
binaryStream.SaveToFile file, adSaveCreateOverWrite
End Sub
I want to get latlng object in google maps in advance. Basically my json result is returning array of address which I need to convert to glatlng to use for markers. But if i will use GeoCoder object then it will send asynch request which I don't want.
Is there any way other than GeoCoder object to convert an address string to GLatLng object?
You can take a look at the json object returned by any query to the maps api.
Then you use the json serializer in system.web.extensions to serialize the json into a class that you have to create from the JSONresponses which you analyze manually.
Note that you can get localized language return results by adding this to the http web request:
wrHTTPrequest.UserAgent = "Lord Vishnu/Transcendental (Vaikuntha;Supreme Personality of Godness)"
wrHTTPrequest.Headers.Add("Accept-Language:" + System.Globalization.CultureInfo.CurrentCulture.Name)
wrHTTPrequest.ContentType = "text/html"
Edit:
The example, from one of my files (remove all the SharpMap.Map stuff, it requires an external assembly.
Copyright (C) 2010 Me. Permission is hereby granted to use it for
good, not evil - if you add me to your thanks list.
Public Class _Default
Inherits System.Web.UI.Page
Protected smmGlobalMap As SharpMap.Map
'http://www.java2s.com/Code/VB/Development/ListallCultureInformation.htm
Public Sub listcultures()
'Dim x As System.DateTime = DateTime.Now
'Response.Write(x.ToString("HH':'mm':'ss MMM d', 'yyyy 'PST'", New System.Globalization.CultureInfo("zh-CN", False)))
Dim info As System.Globalization.CultureInfo
For Each info In System.Globalization.CultureInfo.GetCultures(System.Globalization.CultureTypes.AllCultures)
Response.Write("Deutsch: " + info.DisplayName + " English: " + info.EnglishName + " Native: " + info.NativeName + " Name: " + info.Name + " Codepage: " + info.TextInfo.ANSICodePage.ToString() + "<br />")
If Not info.IsNeutralCulture Then
'item.SubItems.Add(amount.ToString("C", info.NumberFormat))
'item.SubItems.Add(dateNow.ToString("d", info.DateTimeFormat))
End If
Next
End Sub
Public Sub GeoCodeTest()
'Dim GeoCodeResponse As Google.Maps.JSON.cGeoCodeResponse = GetJSONgeodata("San Bernardino, Switzerland")
'Dim GeoCodeResponse As Google.Maps.JSON.cGeoCodeResponse = GetJSONgeodata("北京")
'Dim GeoCodeResponse As Google.Maps.JSON.cGeoCodeResponse = GeoCodeRequest("San Bernardino, Switzerland")
Dim GeoCodeResponse As Google.Maps.JSON.cGeoCodeResponse = GeoCodeRequest("北京")
Response.Write(Seri(GeoCodeResponse))
Response.Write("<br /><br /><br />")
Response.Write(GeoCodeResponse.results(0).address_components(0).long_name)
Response.Write("<br /><br />")
Response.Write(GeoCodeResponse.results(0).geometry.location.lat.ToString)
Response.Write("<br />")
Response.Write(GeoCodeResponse.results(0).geometry.location.lng.ToString)
Response.Write("<br /><br /><br />")
Response.Write(GeoCodeResponse.results(0).geometry.viewport.northeast.lat.ToString)
Response.Write("<br />")
Response.Write(GeoCodeResponse.results(0).geometry.viewport.northeast.lng.ToString)
Response.Write("<br /><br /><br />")
End Sub
Public Function Seri(ByRef GeoData As Google.Maps.JSON.cGeoCodeResponse) As String
Dim jssJSONserializer As System.Web.Script.Serialization.JavaScriptSerializer = New System.Web.Script.Serialization.JavaScriptSerializer()
Dim CommentData As New Google.Maps.JSON.cGeoCodeResponse
Dim str As String = jssJSONserializer.Serialize(GeoData)
Return str
End Function
' http://www.codeproject.com/KB/IP/httpwebrequest_response.aspx
' http://www.linuxhowtos.org/C_C++/socket.htm
' http://en.wikipedia.org/wiki/List_of_countries_by_GDP_(PPP)_per_capita
Public Function GeoCodeRequest(ByRef strAddress As String) As Google.Maps.JSON.cGeoCodeResponse
strAddress = System.Web.HttpUtility.UrlEncode(strAddress) ' Add reference to System.Web
Dim strURL As String = "http://maps.google.com/maps/api/geocode/json?address=" + strAddress + "&sensor=false"
' *** Establish the request
Dim wrHTTPrequest As System.Net.HttpWebRequest = DirectCast(System.Net.WebRequest.Create(strURL), System.Net.HttpWebRequest)
' *** Set properties
wrHTTPrequest.Method = "GET"
wrHTTPrequest.Timeout = 10000 ' 10 secs
wrHTTPrequest.UserAgent = "Lord Vishnu/Transcendental (Vaikuntha;Supreme Personality of Godness)"
wrHTTPrequest.Headers.Add("Accept-Language:" + System.Globalization.CultureInfo.CurrentCulture.Name)
wrHTTPrequest.ContentType = "text/html"
' *** Retrieve request info headers
Dim wrHTTPresponse As System.Net.HttpWebResponse = DirectCast(wrHTTPrequest.GetResponse(), System.Net.HttpWebResponse)
' My Windows' default code-Page
Dim enc As System.Text.Encoding = System.Text.Encoding.GetEncoding(1252)
' Google's code-page
enc = System.Text.Encoding.UTF8
Dim srResponseStream As New System.IO.StreamReader(wrHTTPresponse.GetResponseStream(), enc)
Dim strJSONencodedResponse As String = srResponseStream.ReadToEnd()
wrHTTPresponse.Close()
srResponseStream.Close()
If String.IsNullOrEmpty(strJSONencodedResponse) Then
Return Nothing
End If
Dim jssJSONserializer As System.Web.Script.Serialization.JavaScriptSerializer = New System.Web.Script.Serialization.JavaScriptSerializer()
Dim GeoCodeResponse As New Google.Maps.JSON.cGeoCodeResponse
GeoCodeResponse = jssJSONserializer.Deserialize(Of Google.Maps.JSON.cGeoCodeResponse)(strJSONencodedResponse)
Return GeoCodeResponse
End Function
Public Function GetJSONgeodata(ByVal strAddress As String) As Google.Maps.JSON.cGeoCodeResponse
'strAddress = "Zurich, Switzerland"
strAddress = System.Web.HttpUtility.UrlEncode(strAddress) ' Add reference to System.Web
Dim strURL As String = "http://maps.google.com/maps/api/geocode/json?address=" + strAddress + "&sensor=false"
Dim wwwClient As Net.WebClient = Nothing
Dim strJSONtranslatedText As String = Nothing
Try
'http://www.stevetrefethen.com/blog/UsingGoogleMapsforGeocodinginC.aspx
wwwClient = New Net.WebClient()
wwwClient.Encoding = System.Text.Encoding.UTF8
strJSONtranslatedText = wwwClient.DownloadString(strURL)
Catch ex As Exception
MsgBox(ex.Message)
Finally
wwwClient.Dispose()
wwwClient = Nothing
End Try
If String.IsNullOrEmpty(strJSONtranslatedText) Then
Return Nothing
End If
Dim jssJSONserializer As System.Web.Script.Serialization.JavaScriptSerializer = New System.Web.Script.Serialization.JavaScriptSerializer()
Dim GeoCodeRespone As New Google.Maps.JSON.cGeoCodeResponse
GeoCodeRespone = jssJSONserializer.Deserialize(Of Google.Maps.JSON.cGeoCodeResponse)(strJSONtranslatedText)
Return GeoCodeRespone
End Function
' http://sharpmap.codeplex.com/wikipage?title=CustomTheme
' http://sharpmap.codeplex.com/Thread/View.aspx?ThreadId=28205
Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
'GeoCodeTest()
listcultures()
'Set up the map
smmGlobalMap = InitializeMap(New System.Drawing.Size(CInt(imgMap.Width.Value), CInt(imgMap.Height.Value)))
If Page.IsPostBack Then
'Page is post back. Restore center and zoom-values from viewstate
smmGlobalMap.Center = DirectCast(ViewState("mapCenter"), SharpMap.Geometries.Point)
smmGlobalMap.Zoom = CDbl(ViewState("mapZoom"))
Else
'This is the initial view of the map. Zoom to the extents of the map:
smmGlobalMap.ZoomToExtents()
'Save the current mapcenter and zoom in the viewstate
ViewState.Add("mapCenter", smmGlobalMap.Center)
ViewState.Add("mapZoom", smmGlobalMap.Zoom)
'Create the map
CreateMap()
End If
DistanceAltstRebstein()
End Sub
Protected Sub imgMap_Click(ByVal sender As Object, ByVal e As ImageClickEventArgs)
'Set center of the map to where the client clicked
smmGlobalMap.Center = SharpMap.Utilities.Transform.MapToWorld(New System.Drawing.Point(e.X, e.Y), smmGlobalMap)
'Set zoom value if any of the zoom tools were selected
If rblMapTools.SelectedValue = "0" Then
'Zoom in
smmGlobalMap.Zoom = smmGlobalMap.Zoom * 0.5
ElseIf rblMapTools.SelectedValue = "1" Then
'Zoom out
smmGlobalMap.Zoom = smmGlobalMap.Zoom * 2
End If
'Save the new map's zoom and center in the viewstate
ViewState.Add("mapCenter", smmGlobalMap.Center)
ViewState.Add("mapZoom", smmGlobalMap.Zoom)
'Create the map
CreateMap()
Response.Write("X: " + e.X.ToString + " Y: " + e.Y.ToString + "<br /><br />")
Response.Write("Longitude: " + smmGlobalMap.Center.X.ToString + " Latitude: " + smmGlobalMap.Center.Y.ToString + "<br />")
End Sub
' http://sharpmapv2.googlecode.com/svn/trunk/SharpMap/Rendering/Thematics/CustomTheme.cs
Public Function SetStyle1(ByVal row As SharpMap.Data.FeatureDataRow) As SharpMap.Styles.VectorStyle
Dim vstlStyle1 As SharpMap.Styles.VectorStyle = New SharpMap.Styles.VectorStyle()
vstlStyle1.Enabled = True
vstlStyle1.EnableOutline = True
vstlStyle1.Fill = System.Drawing.Brushes.Yellow
Return vstlStyle1
End Function
'density, countryname
Private Sub InsertData(ByVal strParameter1 As String, ByVal strParameter2 As String)
Dim dbcon As New System.Data.SqlClient.SqlConnection("Data Source=pc-myname\MS_SQL_2005;Initial Catalog=ddb;Integrated Security=SSPI;")
dbcon.Open()
Dim strSQL As String = "IF NOT EXISTS (SELECT * FROM sys.objects WHERE object_id = OBJECT_ID(N'dbo.T_SHP_Country') AND type in (N'U'))"
strSQL += "CREATE TABLE T_SHP_Country( "
strSQL += "SHPC_UID uniqueidentifier NULL, "
strSQL += "SHPC_Density int NULL, "
strSQL += "SHPC_CountryName nvarchar(max) NULL "
strSQL += ") ON [PRIMARY] ;"
Dim dbcmdCheckRequirements As New System.Data.SqlClient.SqlCommand(strSQL, dbcon)
dbcmdCheckRequirements.ExecuteNonQuery()
'dbcmdCheckRequirements.CommandText = "DELETE FROM T_SHP_Country"
'dbcmdCheckRequirements.ExecuteNonQuery()
strParameter1 = strParameter1.Replace("'", "''")
strParameter2 = strParameter2.Replace("'", "''")
'strParameter3 = strParameter3.Replace("'", "''")
strSQL = "INSERT INTO T_SHP_Country "
strSQL += "(SHPC_UID, SHPC_Density, SHPC_CountryName)"
strSQL += "VALUES("
strSQL += "'" + System.Guid.NewGuid.ToString() + "', " 'PLZ_UID, uniqueidentifier
strSQL += " '" + strParameter1 + "', " 'PLZ_Name1, nvarchar(max)
strSQL += " '" + strParameter2 + "' " 'PLZ_State, nvarchar(max)
strSQL += ")"
Dim cmd As New System.Data.SqlClient.SqlCommand(strSQL, dbcon)
cmd.ExecuteNonQuery()
dbcon.Close()
End Sub
Public Function SetStyle(ByVal row As SharpMap.Data.FeatureDataRow) As SharpMap.Styles.VectorStyle
Response.Write("")
If False Then
For i As Integer = 0 To row.Table.Columns.Count - 1 Step 1
Response.Write("<br>" + row.Table.Columns(i).ColumnName + "<br>")
Response.Write("<br>" + row("NAME").ToString + ": " + row("POPDENS").ToString + "<br>")
Next i
End If
Try
'InsertData(row("POPDENS").ToString(), row("NAME").ToString())
Dim vstlStyle As SharpMap.Styles.VectorStyle = New SharpMap.Styles.VectorStyle()
Select Case row("POPDENS")
Case 0 To 5
' Add reference to System.Drawing
Dim colCustomColor As System.Drawing.Color = System.Drawing.Color.FromArgb(50, System.Drawing.Color.Gray)
'Dim customColor As System.Drawing.Color = System.Drawing.Color.FromArgb(255, 0, 110, 255)
Dim sbShadowBrush As System.Drawing.SolidBrush = New System.Drawing.SolidBrush(colCustomColor)
vstlStyle.Fill = sbShadowBrush
Case 6 To 9
vstlStyle.Fill = System.Drawing.Brushes.BlanchedAlmond
Case 10 To 25
vstlStyle.Fill = System.Drawing.Brushes.DarkGreen
Case 26 To 50
vstlStyle.Fill = System.Drawing.Brushes.Green
Case 51 To 100
vstlStyle.Fill = System.Drawing.Brushes.YellowGreen
Case 101 To 200
vstlStyle.Fill = System.Drawing.Brushes.Orange
Case 201 To 250
vstlStyle.Fill = System.Drawing.Brushes.DarkOrange
Case 251 To 300
vstlStyle.Fill = System.Drawing.Brushes.OrangeRed
Case 401 To 600
vstlStyle.Fill = System.Drawing.Brushes.Red
Case 601 To 900
vstlStyle.Fill = System.Drawing.Brushes.DarkRed
Case 901 To 1000
vstlStyle.Fill = System.Drawing.Brushes.Crimson
Case Else
vstlStyle.Fill = System.Drawing.Brushes.Pink
End Select
vstlStyle.EnableOutline = True
Dim clCustomPenColor As System.Drawing.Color = System.Drawing.Color.FromArgb(100, 100, 100, 100)
Dim myPen As New System.Drawing.Pen(clCustomPenColor)
myPen.Width = 0.1
'vstlStyle.Outline = System.Drawing.Pens.Black
vstlStyle.Outline = myPen
Return vstlStyle
'If (row("NAME").ToString().StartsWith("S")) Then
' Dim vstlStyle As SharpMap.Styles.VectorStyle = New SharpMap.Styles.VectorStyle()
' vstlStyle.Fill = System.Drawing.Brushes.Yellow
' Return vstlStyle
'Else
' Return Nothing ' Return null which will render the default style
'End If
Catch ex As Exception
Response.Write(ex.Message)
Return Nothing
End Try
End Function
Sub SetThemeForLayerOnMap(ByRef cstCustomTheme As SharpMap.Rendering.Thematics.CustomTheme, ByVal strLayerName As String, ByRef smmMapParameter As SharpMap.Map)
TryCast(smmMapParameter.GetLayerByName(strLayerName), SharpMap.Layers.VectorLayer).Theme = cstCustomTheme
'CType(smmMapParameter.GetLayerByName(strLayerName), SharpMap.Layers.VectorLayer).Theme = cstCustomTheme
End Sub
Sub ReIndex(ByVal strRelativePath As String)
Dim shfShapeFile As New SharpMap.Data.Providers.ShapeFile(Server.MapPath(strRelativePath), True)
ReIndex(shfShapeFile)
End Sub
Sub ReIndex(ByRef shfShapeFile As SharpMap.Data.Providers.ShapeFile)
If shfShapeFile.IsOpen Then
shfShapeFile.RebuildSpatialIndex()
Else
shfShapeFile.Open()
shfShapeFile.RebuildSpatialIndex()
shfShapeFile.Close()
End If
End Sub
Public Function OldDegreesToRadian(ByVal dblDegrees As Double) As Double
Dim dblRadians = dblDegrees * Math.PI / 180.0
Return dblRadians
End Function
Public Sub DistanceAltstRebstein()
'http://www.getlatlon.com/
Dim allat As Double = 47.377894
Dim allong As Double = 9.539833
Dim reblat As Double = 47.399364
Dim reblong As Double = 9.585995
Dim distance As Double = GetDistance(allat, reblat, allong, reblong)
Response.Write("Distance: " + distance.ToString("#,#.000") + " km")
End Sub
'http://www.codeproject.com/KB/cs/distancebetweenlocations.aspx
'http://www.billsternberger.net/asp-net-mvc/latitude-and-longitude-lookup-with-jquery-c-asp-net-mvc/
'http://webcache.googleusercontent.com/search?q=cache:y6AGC8J7zG8J:bryan.reynoldslive.com/post/Latitude2c-Longitude2c-Bearing2c-Cardinal-Direction2c-Distance2c-and-C.aspx+c%23+get+latitude+longitude&cd=2&hl=en&ct=clnk
Public Function GetDistance(ByVal dblLat1 As Double, ByVal dblLat2 As Double, ByVal dblLong1 As Double, ByVal dblLong2 As Double) As Double
' http://itouchmap.com/latlong.html
' http://mathforum.org/library/drmath/sets/select/dm_lat_long.html
' http://stevemorse.org/jcal/latlon.php
' http://en.wikipedia.org/wiki/Atan2
' http://www.movable-type.co.uk/scripts/latlong.html
' Formula:
' R = Earth's radius (mean radius = 6,371km)
' Δlat = lat2− lat1
' Δlong = long2− long1
' a = sin²(Δlat/2) + cos(lat1)*cos(lat2)*sin²(Δlong/2)
' c = 2*atan2(√a, √(1−a))
' d = R*c
dblLat1 = OldDegreesToRadian(dblLat1)
dblLat2 = OldDegreesToRadian(dblLat2)
dblLong1 = OldDegreesToRadian(dblLong1)
dblLong2 = OldDegreesToRadian(dblLong2)
'http://en.wikipedia.org/wiki/Earth_radius#Mean_radii
Dim dblEarthMeanRadius As Double = 6371.009 ' km
Dim dblHalfDeltaLat As Double = (dblLat2 - dblLat1) / 2.0
Dim dblHalfDeltaLong As Double = (dblLong2 - dblLong1) / 2.0
Dim dblTriangleSideA As Double = Math.Sin(dblHalfDeltaLat) * Math.Sin(dblHalfDeltaLat) + _
Math.Cos(dblLat1) * Math.Cos(dblLat2) * _
Math.Sin(dblHalfDeltaLong) * Math.Sin(dblHalfDeltaLong)
Dim dblTriangleSideC As Double = 2 * Math.Atan2(Math.Sqrt(dblTriangleSideA), Math.Sqrt(1 - dblTriangleSideA))
Dim dblDistance As Double = dblEarthMeanRadius * dblTriangleSideC ' in km
Return dblDistance ' in km
' Note for the English: 1 (statute) mile = 1609.344 m = 1.609344 km
' http://en.wikipedia.org/wiki/Mile#Nautical_mile
dblDistance = dblDistance / 1.609344 ' km to statute miles
Return dblDistance ' in statute miles
End Function
''' <summary>
''' Sets up the map, add layers and sets styles
''' </summary>
''' <param name="outputsize">Initiatial size of output image</param>
''' <returns>Map object</returns>
Private Function InitializeMap(ByVal outputsize As System.Drawing.Size) As SharpMap.Map
'Initialize a new map of size 'imagesize'
Dim map As New SharpMap.Map(outputsize)
map.BackColor = Drawing.Color.AliceBlue
'Set up the countries layer
Dim layCountries As New SharpMap.Layers.VectorLayer("Countries")
'Set the datasource to a shapefile in the App_data folder
Dim sfShapeFile1 As New SharpMap.Data.Providers.ShapeFile(Server.MapPath("~\App_data\Countries.shp"), True)
ReIndex(sfShapeFile1)
'Dim x As System.Data.DataColumnCollection = sfShapeFile1.Columns
'For Each y As DataColumn In x
' Response.Write(y.ColumnName)
' Response.Write(y.DataType.ToString())
'
' Next
'x.Item(0).ColumnName
'x.Item(0).DataType.ToString()
layCountries.DataSource = sfShapeFile1
'Set fill-style to green
Dim MyTheme As New SharpMap.Rendering.Thematics.CustomTheme(AddressOf SetStyle)
Dim defaultstyle As SharpMap.Styles.VectorStyle = New SharpMap.Styles.VectorStyle()
defaultstyle.Fill = System.Drawing.Brushes.Gray
MyTheme.DefaultStyle = defaultstyle
layCountries.Theme = MyTheme
layCountries.Style.Fill = New System.Drawing.SolidBrush(System.Drawing.Color.Green)
'Set the polygons to have a black outline
layCountries.Style.Outline = System.Drawing.Pens.Black
layCountries.Style.EnableOutline = True
'Set up a river layer
Dim layRivers As New SharpMap.Layers.VectorLayer("Rivers")
'Set the datasource to a shapefile in the App_data folder
Dim sh2 As New SharpMap.Data.Providers.ShapeFile(Server.MapPath("~\App_data\Rivers.shp"), True)
ReIndex(sh2)
layRivers.DataSource = sh2
'Define a blue 1px wide pen
layRivers.Style.Line = New System.Drawing.Pen(System.Drawing.Color.Blue, 1)
'Dim x As New SharpMap.Rendering.Thematics.IndividualTheme("abc")
'Add the layers to the map object.
'The order we add them in are the order they are drawn, so we add the rivers last to put them on top
map.Layers.Add(layCountries)
map.Layers.Add(layRivers)
Return map
End Function
''' <summary>
''' Creates the map, inserts it into the cache and sets the ImageButton Url
''' </summary>
Private Sub CreateMap()
If smmGlobalMap Is Nothing Then
Response.Write("<h1 style=""color: red;"">smmGlobalMap is NULL !</h1>")
Else
Dim img As System.Drawing.Image = smmGlobalMap.GetMap()
Dim imgID As String = SharpMap.Web.Caching.InsertIntoCache(1, img)
imgMap.ImageUrl = "getmap.aspx?ID=" & HttpUtility.UrlEncode(imgID)
End If
End Sub
End Class
' http://www.4guysfromrolla.com/articles/052610-1.aspx
' http://code.google.com/apis/maps/faq.html
' http://www.billsternberger.net/asp-net-mvc/latitude-and-longitude-lookup-with-jquery-c-asp-net-mvc/
' http://code.google.com/apis/maps/documentation/geocoding/
' http://code.google.com/apis/maps/documentation/geocoding/index.html
' http://code.google.com/apis/maps/faq.html#geocoder_countries
' http://maps.google.com/maps/api/geocode/json?address=1600+Amphitheatre+Parkway,+Mountain+View,+CA&sensor=false
' http://maps.google.com/maps/api/geocode/json?address=Zurich,+Switzerland&sensor=false
' http://maps.google.com/maps/api/geocode/json?address=SanBernardino,+Switzerland&sensor=false&output=json
' http://maps.google.com/maps/api/geocode/json?address=afsdfKarrrachiii&sensor=false&output=json
' http://math.rice.edu/~pcmi/sphere/sphere.html
' http://math.rice.edu/~pcmi/sphere/
Namespace Google.Maps.JSON
Public Class cAddressComponent
Public long_name
Public short_name
Public types As New List(Of String) '"locality", "country", "postal_code", "sublocality", administrative_area_level_1", administrative_area_level_2", "political"
End Class
Public Class cLocation
Public lat As Double = 0
Public lng As Double = 0
End Class
Public Class cViewPort
Public southwest As New cLocation
Public northeast As New cLocation
End Class
Public Class cBounds
Public southwest As New cLocation
Public northeast As New cLocation
End Class
Public Class cGeometry
Public location As New cLocation
Public location_type As String = "APPROXIMATE" ' "GEOMETRIC_CENTER",
Public viewport As New cViewPort
Public bounds As New cBounds
End Class
Public Class cResult
Public types As New List(Of String) ' "route", "point_of_interest", "establishment", "locality", "sublocality", "political"
Public formatted_address As String
Public address_components As New List(Of cAddressComponent)
Public geometry As New cGeometry
End Class
Public Class cGeoCodeResponse
Public status As String = "ZERO_RESULTS" ' "OK"
Public results As New List(Of cResult)
End Class
End Namespace