How to get GLatLng object from address string in advance in google maps? - latitude-longitude

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

Related

Classic ASP file upload issue

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?

Find and highlight the max value in from multiple column in VB.net

Hi i need anyone to help me,
I need to highlight the highest value from multiple column in table
For Ex:-
I have try out some coding..
Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
UIUtility = New UIUtility()
Dim dtStartProcessTime As DateTime
Dim dtEndProcessTime As DateTime
Dim dtStartQueryTime As DateTime
Dim dtEndQueryTime As DateTime
Dim tsQueryTime As TimeSpan
Dim tsProcessTime As TimeSpan
Dim strCassList As String = ""
Dim dtDefectInfo As New DataTable
Dim dtDefectList As New DataTable
Dim dtResult As New DataTable
Dim dtSelectDefectInfo As New DataTable
Dim strCass_id As String = ""
Dim dtDisplay As New DataTable
Try
dtStartProcessTime = Now
Me.Title = "Shipping Cassettes List"
Dim sEvent_date As String = Request.QueryString("Event_date").Trim()
Dim sRecipe As String = Request.QueryString("recipe").Trim()
Dim sOperation As String = Request.QueryString("operation").Trim()
Dim sEquipment As String = Request.QueryString("equipment").Trim()
lblStatus.Text = "Event_date:" + sEvent_date + _
"<br>Recipe:" + sRecipe + _
"<br>Operation:" + sOperation + _
"<br>Equipment:" + sEquipment + _
"<br><br>"
Dim dtCass As DataTable
Dim drNew As DataRow
Dim SelectDefectInfo As DataRow()
dtStartQueryTime = Now
dtCass = UIUtility.RetrieveShipCassette(sEvent_date, sRecipe, sOperation, sEquipment)
If dtCass.Rows.Count > 0 Then
strCassList = UIUtility.ReturnStringFromdt(dtCass, "shipping_cass_id")
dtDefectInfo = UIUtility.RetrieveDefectInfo(strCassList)
dtDefectList = UIUtility.dtView(dtDefectInfo, "defect")
dtResult.Columns.Add("cass_id", Type.GetType("System.String"))
For i = 0 To dtDefectList.Rows.Count - 1
If Not (dtDefectList.Rows(i).Item("defect").ToString().Equals("NON")) Then
dtResult.Columns.Add(dtDefectList.Rows(i).Item("defect"), Type.GetType("System.Int32")).DefaultValue = 0
End If
Next
For i = 0 To dtCass.Rows.Count - 1
drNew = dtResult.NewRow
strCass_id = dtCass.Rows(i).Item("shipping_cass_id")
drNew("cass_id") = dtCass.Rows(i).Item("cass_id")
SelectDefectInfo = dtDefectInfo.Select("dest_cass_id = '" + strCass_id + "'")
dtSelectDefectInfo = New DataTable
If SelectDefectInfo.Count > 0 Then
dtSelectDefectInfo = SelectDefectInfo.CopyToDataTable
For j = 0 To dtSelectDefectInfo.Rows.Count - 1
If Not (dtSelectDefectInfo.Rows(j).Item("defect").ToString().Trim().Equals("NON")) Then
drNew(dtSelectDefectInfo.Rows(j).Item("defect").ToString()) = dtSelectDefectInfo.Rows(j).Item("defect_count").ToString()
End If
Next
End If
dtResult.Rows.Add(drNew)
Next
End If
dtEndQueryTime = Now
tsQueryTime = dtEndQueryTime.Subtract(dtStartQueryTime)
'For i As Integer = 0 To dtCass.Rows.Count - 1
' drDisplay = dtDisplay.NewRow
' drDisplay("cass_id") = dtCass.Rows(i)("cass_id").ToString()
' dtDisplay.Rows.Add(drDisplay)
' 'dtCass.Rows(i).Item(
'Next
'e.Row.BorderWidth = 2
dgSummary.DataSource = Nothing
dgSummary.DataSource = dtResult
dgSummary.DataBind()
lblStatus.Text += "Total " + dtResult.Rows.Count.ToString + " rows of data found."
dtEndProcessTime = Now
tsProcessTime = dtEndProcessTime.Subtract(dtStartProcessTime)
lblProcessingTime.Text = "Processing Time: " + tsProcessTime.TotalSeconds.ToString + " Secs (Query Time: " + tsQueryTime.TotalSeconds.ToString + " Secs)"
For Each r As GridViewRow In dtResult.Rows()
Dim max As Integer = Integer.MinValue
For i = 1 To r.Cells.Count - 1
Dim n As Integer
If Integer.TryParse(CType(r.Cells(i).Text, String), n) Then max = Math.Max(n, max)
Next
For i = 1 To r.Cells.Count - 1
If r.Cells(i).Text = max Then
r.Cells(i).BackColor = Drawing.Color.Orange
Exit For
End If
Next
Next
Catch ex As Exception
lblMessage.Text = "An error occured:" + ex.Message + " Please contact your administrator."
MyLog.WriteToLog(Me.GetType().Name(), System.Reflection.MethodInfo.GetCurrentMethod().Name, "Exception occured." & vbCrLf & "Error Message:" & ex.Message & vbCrLf & " StackTrace:" & ex.StackTrace)
End Try
End Sub
Protected Sub dgSummary_RowDataBound(ByVal sender As Object, ByVal e As System.Web.UI.WebControls.GridViewRowEventArgs) Handles dgSummary.RowDataBound
Dim cass_id As String = ""
'Dim dtResult As New DataTable
'Dim DataGridView1 As New DataTable
Dim dtCass As New DataTable
If e.Row.RowType = DataControlRowType.DataRow Then
cass_id = e.Row.Cells(0).Text.Trim
If Not e.Row.Cells(0).Text.Trim.Equals("") Then
e.Row.Cells(0).Attributes.Add("Title", "Click and view the cassette details")
e.Row.Cells(0).Attributes("onmouseover") = "this.style.color='DodgerBlue';this.style.cursor='hand';"
e.Row.Cells(0).Attributes("onmouseout") = "this.style.color='Black';"
e.Row.Cells(0).Attributes("onClick") = _
String.Format("window.open('{0}','_blank','scrollbars=yes,status=yes,location=yes,toolbar=yes,menubar=yes,resizable=Yes')", _
ResolveUrl(System.Configuration.ConfigurationManager.AppSettings("SFEHReportLink_SSL") + cass_id))
e.Row.Cells(0).Style("cursor") = "pointer"
End If
End Sub
Maybe theres any coding that more easier than this since i have 17items
Thank you so much for you guys help.
After i add the new code, i got this error,
new error
maybe this example can help you
Private Sub Button6_Click(sender As Object, e As EventArgs) Handles Button6.Click
For Each r As DataGridViewRow In DataGridView1.Rows
Dim max As Integer = Integer.MinValue
For i = 1 To r.Cells.Count - 1
Dim n As Integer
If Integer.TryParse(CType(r.Cells(i).Value, String), n) Then max = Math.Max(n, max)
Next
For i = 1 To r.Cells.Count - 1
If r.Cells(i).Value = max Then
r.Cells(i).Style.BackColor = Color.Orange
Exit For
End If
Next
Next
End Sub

VB linq to entities Field called FIELD_NAME does not exist

I have spent the last hours trying to figure out what is causing this exception : Field called GENDER_DESC does not exist. Here are my codes:
Public Class RelationPatient
Public PatNetId As String
Public PatNetIdRel As String
Public Nom As String
Public Prenom As String
Public Sexe As String
Public TypeRel As String
Public Ordre As String
Public DateEnrol As Date
End Class
Public Shared Function GetRelPatient(ByVal PatNetId As String) As List(Of RelationPatient)
Using context As New DAL.SanteReprodEntities
context.Database.Connection.Open()
Dim patient As List(Of RelationPatient)
patient = (From p In context.PAT_REL
Join pa In context.PATIENTS.Include("GENDER_REF") On p.PAT_NET_ID_REL Equals (pa.PAT_NET_ID)
Join pn In context.PAT_NAME On pn.PAT_NET_ID Equals (p.PAT_NET_ID_REL)
Where p.PAT_NET_ID = PatNetId _
And p.VOIDED = 2 Select New RelationPatient With {.PatNetId = p.PAT_NET_ID, .PatNetIdRel = p.PAT_NET_ID_REL, .Nom = pn.LASTNAME, .Prenom = pn.FIRSTNAME, .Sexe = pa.GENDER_REF.GENDER_DESC, .TypeRel = p.REL_TYPE_ID, .Ordre = p.PATIENT_INDEX_TEMOIN, .DateEnrol = pa.ENROL_DATE}).ToList
Return patient
context.Database.Connection.Close()
End Using
End Function
Private Sub FrmLienPatient_Shown(sender As Object, e As EventArgs) Handles MyBase.Shown
DsEnrolement.PAT_REL.Clear()
DsEnrolement.Merge(DAL.dalManager.GetPatRelation(PAT_NET_ID))
Dim patRel As List(Of DAL.RelationPatient)
Dim sexe As String = String.Empty
patRel = DAL.dalManager.GetRelPatient(PAT_NET_ID)
If patRel IsNot Nothing Then
If patRel.Count > 0 Then
For Each rel As DAL.RelationPatient In patRel
MsgBox(rel.PatNetIdRel + ", " + rel.Nom + ", " + rel.Prenom + ", " + rel.Sexe + ", " + rel.TypeRel + ", " + rel.Ordre + ", " + rel.DateEnrol.ToShortDateString) 'This message is displayed well
PATI_RELDataGridView.Rows.Add(New String() {rel.PatNetIdRel, rel.Nom, rel.Prenom, sexe, rel.TypeRel, rel.Ordre, rel.DateEnrol.ToShortDateString}) 'Even if I put any string there like PATI_RELDataGridView.Rows.Add(New String() {"", "", "", "", "", "", ""}) the result is the same
Next
End If
End If
End Sub
Thanks in advance for your help.

Merge pdf using Docotic.Pdf Library

I already have a class that does this but I want you to finish programming a NEW class using the Docotic.Pdf Library Their website for your reference is: http://bitmiracle.com/pdf-library/
this code which I write.
`Public Class Form1
Private Sub butMergePdfs_Click(sender As System.Object, e As System.EventArgs) Handles butMergePdfs.Click
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Load some sample PDF files into the string arrays
'In production it will read the files into the string arrays
'from a database.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim strMergeFiles(3) As String
Dim strMergeTitles(3) As String
strMergeFiles(0) = "D:\Nayeem_Mansoori\Cis_Projects\Cis_Projects\SanjayVerma\PdfMergeTest\PDF_1.pdf"
strMergeFiles(1) = "D:\Nayeem_Mansoori\Cis_Projects\Cis_Projects\SanjayVerma\PdfMergeTest\PDF_2.pdf"
strMergeFiles(2) = "D:\Nayeem_Mansoori\Cis_Projects\Cis_Projects\SanjayVerma\PdfMergeTest\PDF_3.pdf"
'strMergeFiles(0) = "C:\Temp\PDF_1.pdf"
'strMergeFiles(1) = "C:\Temp\PDF_2.pdf"
'strMergeFiles(2) = "C:\Temp\PDF_3.pdf"
strMergeTitles(0) = "OUTLINE_1"
strMergeTitles(1) = "OUTLINE_2"
strMergeTitles(2) = "OUTLINE_3"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This shows how the old class worked. The new class needs to work
'with exactly the same parameters.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Dim myMerge As New clsMerge_OLD
'Dim strFileName As String = System.IO.Path.GetRandomFileName & ".pdf"
'Dim strOutputFileAndPath As String = "C:\temp\" & strFileName
Dim myMerge As New clsMerge_NEW
Dim strFileName As String = System.IO.Path.GetRandomFileName & ".pdf"
Dim strOutputFileAndPath As String = "C:\temp\" & strFileName
'Merge the files.
myMerge.MergeFiles(strMergeFiles, strMergeTitles, strOutputFileAndPath)
'Shop any merge errors.
If myMerge.Errors <> "" Then
MsgBox(myMerge.Errors)
End If
'Open the merged PDF
Process.Start(strOutputFileAndPath)
myMerge = Nothing
End Sub
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs)
MsgBox(System.IO.Directory.GetCurrentDirectory())
End Sub
End Class
Imports BitMiracle.Docotic.Pdf
Public Class clsMerge_NEW
Private mstrErrors As String
Private mboolCurrentFileIsIrefStream As Boolean
Private mboolPadPageCountToEven As Boolean
Private mRand As Random
Public ReadOnly Property Errors() As String
Get
Return mstrErrors
End Get
End Property
Public Sub New()
mstrErrors = ""
End Sub
Public Function MergeFiles(ByVal SourceFiles() As String _
, ByVal SourceTitles() As String _
, ByVal DestinationFile As String) As Boolean
Dim boolReturnVal As Boolean = True
'clear error variable
mstrErrors = ""
'If the destination merged PDF file exists, then delete it.
Try
If System.IO.File.Exists(DestinationFile) = True Then
System.IO.File.Delete(DestinationFile)
End If
Catch ex As Exception
mstrErrors = mstrErrors & " Cannot delete destination file:" & DestinationFile & ". Error is: " & ex.Message & vbCrLf
boolReturnVal = False
End Try
If boolReturnVal = True Then 'if still true then continue!
'Iterate the string array.
For i As Int32 = 0 To UBound(SourceFiles) - 1
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'
' !!!! FINISH THIS CODE - MERGE THE PDF's !!!!!!!
'
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Ensure OUTLINES are created in the destination PDF file!!!!!
'The TITLES passed in SourceTitles are the OUTLINES.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Next
End If
Return boolReturnVal
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'
' Here is a C# example of how to use the class.
'
'-------------------------------------------------------------------------------
'
' using (PdfDocument pdf = new PdfDocument())
' {
' pdf.PageMode = PdfPageMode.UseOutlines;
' pdf.Append("d:\\0000-2981A.pdf");
'
' pdf.Append("d:\\0000-2981B.pdf");
' pdf.RemovePage(0);
'
'
' PdfOutlineItem root = pdf.OutlineRoot;
'
' for (int i = 0; i < pdf.PageCount; ++i)
' {
' int pgcount = i + 1;
' PdfOutlineItem outlineForPage = root.AddChild("Page " + pgcount.ToString(), i);
' }
'
' pdf.Save(pathToFile);
' }
End Class
Please can any one help me.
Your question could be more specific. I am not sure I understood it right, but please try following sample code.
The sample code combines different documents into one PDF file and creates bookmarks. Each bookmark points to the first page of original document. Bookmarks titles are provided as parameter to the function.
Please note that the code is auto-converted from C#.
Public Shared Sub MergeFiles(sourceFiles As String(), bookmarkTitles As String(), destination As String)
Using pdf As New PdfDocument()
Dim targetPageIndex As Integer = 0
For i As Integer = 0 To sourceFiles.Length - 1
Dim currentName As String = sourceFiles(i)
If i = 0 Then
pdf.Open(currentName)
Else
pdf.Append(currentName)
End If
pdf.OutlineRoot.AddChild(bookmarkTitles(i), targetPageIndex)
targetPageIndex = pdf.PageCount
Next
pdf.PageMode = PdfPageMode.UseOutlines
pdf.Save(destination)
End Using
End Sub
Here is the C# version for the reference:
public static void MergeFiles(string[] sourceFiles, string[] bookmarkTitles, string destination)
{
using (PdfDocument pdf = new PdfDocument())
{
int targetPageIndex = 0;
for (int i = 0; i < sourceFiles.Length; i++)
{
string currentName = sourceFiles[i];
if (i == 0)
pdf.Open(currentName);
else
pdf.Append(currentName);
pdf.OutlineRoot.AddChild(bookmarkTitles[i], targetPageIndex);
targetPageIndex = pdf.PageCount;
}
pdf.PageMode = PdfPageMode.UseOutlines;
pdf.Save(destination);
}
}

How to append new node to existing node in xml

Following is my xml file code
<XMLFile>
<EMail>
<From>
<Address>dddd#acd.com</Address>
</From>
<Receipent> <To>eeee#qwe.com</To> </Receipent>
<Subject>fffffsadasd</Subject>
<Body>ggggasdsd</Body>
</EMail>
</XMLFile>
i hve a sent button.On clicking that button each time i want to append Enail node and correponding childnodes to existing xml file.
In sent buttonclick i hve written following code.
Dim currNode As XmlNode
Dim doc As New XmlDocument
doc.LoadXml(("<XMLFile>" + " <EMail></EMail>" + "</XMLFile>"))
Dim docFrag As XmlDocumentFragment = doc.CreateDocumentFragment()
docFrag.InnerXml = "<From>" + " <Address>" + txtFrom.Text + " </Address>" + "</From>"
currNode = doc.DocumentElement.FirstChild
currNode.InsertAfter(docFrag, currNode.LastChild)
docFrag.InnerXml = "<Receipent>" + " <To>" + txtTo.Text + " </To>" + "</Receipent>"
currNode = doc.DocumentElement.FirstChild
currNode.InsertAfter(docFrag, currNode.LastChild)
docFrag.InnerXml = "<Subject>" + txtSubject.Text + "</Subject>"
currNode = doc.DocumentElement.FirstChild
currNode.InsertAfter(docFrag, currNode.LastChild)
docFrag.InnerXml = "<Body>" + txtBody.Text + "</Body>"
currNode = doc.DocumentElement.FirstChild
currNode.InsertAfter(docFrag, currNode.LastChild)
doc.Save("C:\xmlmailfile.xml")
What modification i have to make in button click
Something like this should do it. An XMLTextWriter might be better for your purposes though:
Private Function GenerateXML(ByVal emails As List(Of Email)) As String
Dim sb As New System.Text.StringBuilder
Using sw As New IO.StringWriter(sb), xt As New Xml.XmlTextWriter(sw)
xt.WriteStartElement("xmlDoc")
For i As Integer = 0 To emails.Count - 1
xt.WriteStartElement("email")
xt.WriteStartElement("From")
xt.WriteElementString("address", emails(i).From)
xt.WriteEndElement()
xt.WriteStartElement("Receipent")
xt.WriteElementString("to", emails(i).Recipient)
xt.WriteEndElement()
xt.WriteElementString("subject", emails(i).Subject)
xt.WriteElementString("body", emails(i).Body)
xt.WriteEndElement()
Next
xt.WriteEndElement()
End Using
Return sb.ToString
End Function
EDIT:
This need error handling etc, but should work for you. There are some cases where it will break (such as if a file exists but is empty) which you will need to solve yourself.
Module consoleTestApp
Private _path As String = "c:\output.xml"
//Just pretend these are text boxes
Public txtFrom As String
Public txtRecipient As String
Public txtSubject As String
Public txtBody As String
Sub Main()
txtFrom = "from1"
txtRecipient = "rec1"
txtSubject = "subj1"
txtBody = "body1"
AddNewEmail()
txtFrom = "from2"
txtRecipient = "rec2"
txtSubject = "subj2"
txtBody = "body2"
AddNewEmail()
End Sub
Private Sub AddNewEmail()
If Not IO.File.Exists(_path) Then
Using xt As New Xml.XmlTextWriter(_path, System.Text.Encoding.UTF8)
xt.WriteStartElement("xmlDoc")
xt.WriteEndElement()
End Using
End If
Dim xD As New Xml.XmlDocument
xD.Load(_path)
Dim xN As Xml.XmlNode = xD.CreateNode(Xml.XmlNodeType.Element, String.Empty, "email", String.Empty)
xN.InnerXml = GenerateXML()
xD.SelectSingleNode("//xmlDoc").AppendChild(xN)
xD.Save(_path)
End Sub
Private Function GenerateXML() As String
Dim sb As New System.Text.StringBuilder
Using sw As New IO.StringWriter(sb), xt As New Xml.XmlTextWriter(sw)
xt.WriteStartElement("From")
xt.WriteElementString("address", txtFrom)
xt.WriteEndElement()
xt.WriteStartElement("Receipent")
xt.WriteElementString("to", txtRecipient)
xt.WriteEndElement()
xt.WriteElementString("subject", txtSubject)
xt.WriteElementString("body", txtBody)
End Using
Return sb.ToString
End Function
End Module