VB linq to entities Field called FIELD_NAME does not exist - vb.net

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.

Related

I now am getting this error "The type initializer for 'iTrac.SalesOrder' threw an exception."

I have a function that works fine iTrac.SalesOrder.SalesOrdersByBody_JB, when I try to call it from the web service, it fails and throws the exception
"The type initializer for 'iTrac.SalesOrder' threw an exception."
I see this is a fairly common situation and I did go through ALL of the similar questions but I did not see any answer to my problem, or maybe I am too much of a newbie to recognize the answer...?
went through all the similar questions.
Private Sub BrowserMailSender(obj As Object, e As EventArgs)
Dim x As New List(Of iTrac.JBSODetail)
Try
FileIO.WriteToFile("service is started:" + Now + vbNewLine)
x = iTrac.SalesOrder.SalesOrdersByBody_JB(241)
FileIO.WriteToFile(x.ToString)
Catch ex As Exception
FileIO.WriteToFile(ex.Message + vbNewLine)
End Try
End Sub
function that throws the exception
Public Shared Function SalesOrdersByBody_JB(ByVal BodyID As String) As List(Of JBSODetail)
Dim SalesOrderList As New List(Of JBSODetail)
Using context = New iTracContext
Dim BOMList = New List(Of Integer)
Dim StatusList As New List(Of String)
BOMList = context.BillOfMaterials.Where(Function(b) b.Child =
BodyID And b.ParentClass = "RTS").Select(Function(b)
b.Parent).ToList
If BOMList Is Nothing Then
Return Nothing
Else
StatusList.Add("OPEN")
StatusList.Add("HOLD")
StatusList.Add("BACKORDER")
End If
Dim query =context.JBSODetails.Include
("Part").Include("SOHeader").AsQueryable
If Not String.IsNullOrEmpty(BodyID) Then
query = query.Where(Function(s)
BOMList.Contains(s.pid) And
StatusList.Contains(s.status.ToUpper))
End If
Return query.OrderBy(Function(s) s.promised_date).ToList
End Using
End Function
Imports System.Data.SqlClient
Imports System.ComponentModel.DataAnnotations
Imports iTrac
<Table("tblSODetails")>
Public Class SalesOrder
<Key()>
Public Property sid As Decimal
Public Property SalesOrderNumber As String
Public Property SalesOrderLine As String
Public Property NeedDate As Date
Public Property PromisedDate As Date
Public Property ShipTo As String
Public Property Customer As String
<Column("UnitPriceOfOrder")>
Public Property UnitPrice As Decimal?
<Column("PriceUnitOfOrder")>
Public Property PriceUnit As String
Public Property OrderQuantity As Decimal?
Public Property OrderBalance As Decimal?
Public Property OrderEntryDate As Date
<Column("Material")>
Public Property CustomerPartNumber As String
Public Property LastUpdated As Date
Public Property CustomerPO As String
<NotMapped()>
Public Property NormalizedPartNumber As String
Public Property OfficeNote As String
Public Property pid As Integer?
Public Property aid As Integer?
Public Property cid As Integer?
Public Property TransferTime As Date
Public Property ShipVia As String
<NotMapped>
Public Property RunningTotal As Integer?
<ForeignKey("pid")>
Public Property Inventory As CompiledInventory
<ForeignKey("pid")>
Public Property Part As Part
<NotMapped()>
Public Property RTS
<NotMapped()>
Public Property Plate
<NotMapped()>
Public Property Machined
<NotMapped()>
Public Property Status
Private Shared ConnectionString As String = BrowserUtilities.Settings.ConnectionString
Public ReadOnly Property Blocked As Boolean
Get
Return ShippingBlock.BlockExists(SalesOrderNumber, SalesOrderLine)
End Get
End Property
Public Shared Function OpenSalesOrderList(ByVal CustomerName As String,
ByVal ShipToAddress As String,
ByVal CustomerPartNumber As String,
ByVal CutOffDate As String,
ByVal NormalizedID As String,
ByVal UpdatedWindow As String,
Optional ByVal CustomerPO As String = "") As List(Of SalesOrder)
Dim SalesOrderList As New List(Of SalesOrder)
Using Connection As New SqlConnection(ConnectionString)
Connection.Open()
Dim sqlString = ""
Dim sqlWhereClause = ""
If CustomerName <> "" Then
sqlWhereClause = " where customer = '" & CustomerName & "'"
End If
If ShipToAddress <> "" Then
If sqlWhereClause > "" Then
sqlWhereClause += " and shipto = '"
Else
sqlWhereClause += " where shipto = '"
End If
sqlWhereClause += ShipToAddress + "'"
End If
If CustomerPartNumber <> "" Then
If sqlWhereClause > "" Then
sqlWhereClause += " and material like '"
Else
sqlWhereClause += " where material like '"
End If
sqlWhereClause += CustomerPartNumber + "'"
End If
If CustomerPO <> "" Then
If sqlWhereClause > "" Then
sqlWhereClause += " and customerpo = '"
Else
sqlWhereClause += " where customerpo = '"
End If
sqlWhereClause += CustomerPO + "'"
End If
If NormalizedID <> "" Then
If NormalizedID <> "0" Then
If sqlWhereClause > "" Then
sqlWhereClause += " and pid = '"
Else
sqlWhereClause += " where pid = '"
End If
sqlWhereClause += NormalizedID + "'"
End If
End If
If CutOffDate <> "" And CustomerPO = "" Then
If sqlWhereClause > "" Then
sqlWhereClause += " and promiseddate <= '"
Else
sqlWhereClause += " where promiseddate <= '"
End If
sqlWhereClause += CutOffDate + "'"
End If
If UpdatedWindow <> "" Then
If sqlWhereClause > "" Then
sqlWhereClause += " and "
Else
sqlWhereClause += "where "
End If
sqlWhereClause += "lastupdated between '" & Now.AddHours(-Val(UpdatedWindow)) & "' and '" & Now & "'"
End If
sqlString = "Select s.*, (select NormalizedPartNumber from tblPart where id = pid) as NormalizedPartNumber from tblSODetails as s" & sqlWhereClause
If UpdatedWindow <> "" Then
sqlString += " order by customer, normalizedpartnumber, promiseddate"
Else
sqlString += " order by promiseddate"
End If
Dim command = New SqlCommand(sqlString, Connection)
Dim dataReader As SqlDataReader = command.ExecuteReader()
While dataReader.Read()
Dim so = New SalesOrder()
so.MapDataReader(dataReader, 1)
SalesOrderList.Add(so)
End While
End Using
Return SalesOrderList
End Function
Private Sub MapDataReader(ByVal dataReader As IDataReader, ByVal Method As Integer)
Select Case Method
Case 0, 1
sid = If(IsDBNull(dataReader("sid")), "", dataReader("sid"))
SalesOrderNumber = If(IsDBNull(dataReader("salesordernumber")), "", dataReader("salesordernumber"))
SalesOrderLine = If(IsDBNull(dataReader("salesorderline")), "", dataReader("salesorderline"))
PromisedDate = If(IsDBNull(dataReader("promiseddate")), "", dataReader("promiseddate"))
ShipTo = If(IsDBNull(dataReader("shipto")), "", dataReader("shipto"))
Customer = If(IsDBNull(dataReader("customer")), "", dataReader("customer"))
UnitPrice = If(IsDBNull(dataReader("unitpriceoforder")), 0, dataReader("unitpriceoforder"))
PriceUnit = If(IsDBNull(dataReader("priceunitoforder")), "", dataReader("priceunitoforder"))
OrderQuantity = If(IsDBNull(dataReader("orderquantity")), "", dataReader("orderquantity"))
OrderBalance = If(IsDBNull(dataReader("orderbalance")), "", dataReader("orderbalance"))
OrderEntryDate = If(IsDBNull(dataReader("orderentrydate")), "", dataReader("orderentrydate"))
CustomerPartNumber = If(IsDBNull(dataReader("material")), "", dataReader("material"))
LastUpdated = If(IsDBNull(dataReader("lastupdated")), "", dataReader("lastupdated"))
CustomerPO = If(IsDBNull(dataReader("customerpo")), "", dataReader("customerpo"))
OfficeNote = If(IsDBNull(dataReader("officenote")), "", dataReader("officenote"))
pid = If(IsDBNull(dataReader("pid")), 0, dataReader("pid"))
aid = If(IsDBNull(dataReader("aid")), 0, dataReader("aid"))
cid = If(IsDBNull(dataReader("cid")), 0, dataReader("cid"))
TransferTime = dataReader("transfertime")
ShipVia = If(IsDBNull(dataReader("shipvia")), "", dataReader("shipvia"))
NeedDate = If(IsDBNull(dataReader("new_promised_date")), dataReader("promiseddate"), dataReader("new_promised_date"))
If Method = 1 Then NormalizedPartNumber = If(IsDBNull(dataReader("normalizedpartnumber")), "", dataReader("normalizedpartnumber"))
Case 2
Customer = If(IsDBNull(dataReader("customer")), "Unknown", dataReader("customer"))
End Select
End Sub
Public Shared Function SalesOrdersByBody(ByVal BodyID As String, ByVal CustomerPartNumber As String) As List(Of SalesOrder)
Dim SalesOrderList As New List(Of SalesOrder)
Dim CP As New Part
Using Connection As New SqlConnection(ConnectionString)
Dim sqlString = ""
Connection.Open()
If BodyID > "" Then
sqlString = "Select s.*, d.new_promised_date from tblPart as p " &
"inner join tblSODetails as s on p.id = s.pid " &
"inner join tblJBSODetails d on d.sales_order = s.salesordernumber " &
"inner join tblBillOfMaterial as b on p.id = b.parent and parentclass = 'rts' " &
"where b.child = " & BodyID & " order by s.promiseddate"
Else
sqlString = "Select s.*, d.new_promised_date from tblPart as p " &
"inner join tblSODetails as s on s.pid = p.id " &
"inner join tblJBSODetails d on d.sales_order = s.salesordernumber " &
"where p.CustomerPartNumber = '" & CustomerPartNumber & "' " &
"order by s.promiseddate"
End If
Dim command = New SqlCommand(sqlString, Connection)
Dim dataReader As SqlDataReader = command.ExecuteReader()
While dataReader.Read()
Dim so = New SalesOrder()
so.MapDataReader(dataReader, 0)
SalesOrderList.Add(so)
End While
End Using
Return SalesOrderList
End Function
Public Shared Function SalesOrdersByBody_JB(ByVal BodyID As String) As List(Of JBSODetail)
Dim SalesOrderList As New List(Of JBSODetail)
Using context = New iTracContext
Dim BOMList = New List(Of Integer)
Dim StatusList As New List(Of String)
BOMList = context.BillOfMaterials.Where(Function(b) b.Child = BodyID And b.ParentClass = "RTS").Select(Function(b) b.Parent).ToList
If BOMList Is Nothing Then
Return Nothing
Else
StatusList.Add("OPEN")
StatusList.Add("HOLD")
StatusList.Add("BACKORDER")
End If
Dim query = context.JBSODetails.Include("Part").Include("SOHeader").AsQueryable
If Not String.IsNullOrEmpty(BodyID) Then
query = query.Where(Function(s) BOMList.Contains(s.pid) And StatusList.Contains(s.status.ToUpper))
End If
Return query.OrderBy(Function(s) s.promised_date).ToList
End Using
End Function
Public Shared Function SalesOrdersByPartID(ByVal PartID As Integer) As List(Of SalesOrder)
Dim SalesOrderList As New List(Of SalesOrder)
Using Connection As New SqlConnection(ConnectionString)
Dim sqlString = ""
Connection.Open()
sqlString = "Select s.*, d.new_promised_date from tblPart as p " &
"inner join tblSODetails as s on p.id = s.pid " &
"inner join tblJBSODetails d on d.sales_order = s.salesordernumber " &
"inner join tblBillOfMaterial as b on p.id = b.parent and parentclass = 'rts' " &
"where b.parent = " & PartID & " order by s.promiseddate"
Dim command = New SqlCommand(sqlString, Connection)
Dim dataReader As SqlDataReader = command.ExecuteReader()
While dataReader.Read()
Dim so = New SalesOrder()
so.MapDataReader(dataReader, 0)
SalesOrderList.Add(so)
End While
End Using
Return SalesOrderList
'Using context = New iTracContext
' Return context.SalesOrders.Where(Function(s) s.pid = PartID).ToList
'End Using
End Function
Public Shared Function SalesOrdersByPartID_JB(ByVal PartID As Integer) As List(Of JBSODetail)
Dim SalesOrderList As New List(Of JBSODetail)
Using context = New iTracContext
Dim query = context.JBSODetails.Include("SOHeader").Include("Part").AsQueryable
If Not String.IsNullOrEmpty(PartID) Then query = query.Where(Function(s) s.pid = PartID)
query = query.Where(Function(s) s.status = "Open")
Return query.OrderBy(Function(s) s.promised_date).ToList
End Using
End Function
Public Function CustomerList(ByVal CutoffDate As Date) As List(Of String)
Dim CList As New List(Of String)
Using Connection As New SqlConnection(ConnectionString)
Connection.Open()
Dim sqlString = "select customer from tblSODetails where promiseddate <= '" & CutoffDate.ToShortDateString & "' " &
"group by customer order by customer"
Dim command = New SqlCommand(sqlString, Connection)
Dim dataReader As SqlDataReader = command.ExecuteReader()
While dataReader.Read()
MapDataReader(dataReader, 2)
CList.Add(Customer)
End While
End Using
Return CList
End Function
Public Shared Function OpenList(ByVal CutoffDate As Date, ByVal Customer As String, ByVal ShipVia As String) As List(Of SalesOrder)
Using context = New iTracContext
Dim query = context.SalesOrders.Include("Inventory").Include("Part").AsQueryable
query = query.Where(Function(s) s.PromisedDate <= CutoffDate)
If Not String.IsNullOrEmpty(Customer) Then query = query.Where(Function(s) s.Customer = Customer)
If Not String.IsNullOrEmpty(ShipVia) Then query = query.Where(Function(s) s.ShipVia = ShipVia)
Return query.OrderBy(Function(l) l.PromisedDate).ToList
End Using
End Function
Public ReadOnly Property PartNumber As String
Get
If Part IsNot Nothing Then
Return Part.NormalizedPartNumber
Else
Return Nothing
End If
End Get
End Property
Public ReadOnly Property rtsOk As Integer?
Get
If Inventory IsNot Nothing Then
Return Inventory.rts_ok
Else
Return Nothing
End If
End Get
End Property
Public ReadOnly Property rtsHold As Integer?
Get
If Inventory IsNot Nothing Then
Return Inventory.rts_hold
Else
Return Nothing
End If
End Get
End Property
Public ReadOnly Property rtsRejected As Integer?
Get
If Inventory IsNot Nothing Then
Return Inventory.rts_rejected
Else
Return Nothing
End If
End Get
End Property
Public ReadOnly Property rtsOut As Integer?
Get
If Inventory IsNot Nothing Then
Return Inventory.rts_out
Else
Return Nothing
End If
End Get
End Property
Public ReadOnly Property rtsInReceving As Integer?
Get
If Inventory IsNot Nothing Then
Return Inventory.rts_receiving
Else
Return Nothing
End If
End Get
End Property
Public ReadOnly Property rtsInShipping As Integer?
Get
If Inventory IsNot Nothing Then
Return Inventory.rts_in_shipping
Else
Return Nothing
End If
End Get
End Property
Public ReadOnly Property rtsIssued As Integer?
Get
If Inventory IsNot Nothing Then
Return Inventory.rts_issued
Else
Return Nothing
End If
End Get
End Property
End Class
This line is throwing the exception:
Private Shared ConnectionString As String = BrowserUtilities.Settings.ConnectionString
Something in the expression BrowserUtilities.Settings.ConnectionString is throwing an exception. It's unclear what it is but I would say that NullReferenceException is the most likely candidate. Maybe BrowserUtilities.Settings is Nothing. It's just guesswork at this point. You'll have to debug it to find out.
When a Shared (static in C#) field, such as ConnectionString in your code, has an initialization expression, that initialization occurs in a special method called a "type initializer". All initialization expressions for the Shared fields in a type are grouped into the type initializer and executed before the first time that type is used*.
*This is a slight simplification for the sake of this explanation.
The first time you called the SalesOrdersByBody_JB function, it first had to initialize the type, which means running the type initializer to initialize ConnectionString. It looked like SalesOrdersByBody_JB threw the exception, but it was really happening slightly before that.

How to return from ienumerable function in vb.net

Public Shared Function GetDataSet() As IEnumerable(Of SerialData)
Dim sCon As New SQLConnect
Dim strsql As String
Dim p As New Control
sCon.sqlAdp = New SqlDataAdapter
strsql = "select serialid," & _
" serialno," & _
" serialdesc," & _
" b.materialname," & _
" b.drawing," & _
" a.workorder," & _
" isnull((select top 1 patno from patternmaster where patid = a.patid),'Not Defined') as patno," & _
" case when a.activeflag = 1 then 'True' else 'False' end as activeflag" & _
" from serialmaster a," & _
" materialmaster b" & _
" where 1 = 1" & _
" and a.materialid = b.materialid" & _
" and b.activeflag = 1"
sCon.sqlCmd.CommandText = strsql
sCon.sqlAdp.SelectCommand = sCon.sqlCmd
sCon.sqlAdp.Fill(sCon.DS, "Listing")
Dim dtTable As DataTable
dtTable = sCon.DS.Tables("Listing")
' For Each row As DataRow In dtTable.Rows
' Return dtTable.AsEnumerable().[Select](Function(row) New With { _
' Key .serialid = row("serialid"), _
' Key .serialno = row("serialno"), _
' Key .serialdesc = row("serialdesc"), _
' Key .materialname = row("materialname"), _
' Key .drawing = row("drawing"), _
' Key .workorder = row("workorder"), _
' Key .patno = row("patno") _
'})
' Next
For Each row As DataRow In dtTable.Rows
p.serialid.Add(row("serialid"))
p.serialno.Add(row("serialno"))
p.serialdesc.Add(row("serialdesc"))
p.materialname.Add(row("materialname"))
p.drawing.Add(row("drawing"))
p.workorder.Add(row("workorder"))
p.patno.Add(row("patno"))
Next
Return p
End Function
Control class:
Public Class Control
Public serialid As New Generic.List(Of String)
Public serialno As New Generic.List(Of String)
Public serialdesc As New Generic.List(Of String)
Public materialname As New Generic.List(Of String)
Public drawing As New Generic.List(Of String)
Public workorder As New Generic.List(Of String)
Public patno As New Generic.List(Of String)
Public result As New Generic.List(Of String)
End Class
ServerSidePro class:
Public Class ServerSidePro
Implements System.Web.IHttpHandler
Sub ProcessRequest(ByVal context As HttpContext) Implements IHttpHandler.ProcessRequest
Dim d As New Control
' Those parameters are sent by the plugin
Dim iDisplayLength = Integer.Parse(context.Request("iDisplayLength"))
Dim iDisplayStart = Integer.Parse(context.Request("iDisplayStart"))
Dim iSortCol = Integer.Parse(context.Request("iSortCol_0"))
Dim iSortDir = context.Request("sSortDir_0")
'Fetch the data from a repository (in my case in-memory)
'Dim p = SerialData.GetDataSet()
Dim p = DirectCast(SerialData.GetDataSet(), IEnumerable(Of SerialData))
' prepare an anonymous object for JSON serialization
Dim aaData2 = p.select(Function(h) New With {h.serialid, h.serialno, h.serialdesc, _
h.materialname, h.drawing, h.workorder, h.patno}).Skip(iDisplayStart).Take(iDisplayLength)
Dim str As New List(Of String())
For Each item In aaData2
Dim arr As String() = New String(6) {item.serialid, item.serialno, item.serialdesc, _
item.materialname, item.drawing, item.workorder, item.patno}
str.Add(arr)
Next
Dim result = New With { _
Key .iTotalRecords = p.Count(), _
Key .iTotalDisplayRecords = p.Count(), _
Key .aaData = str
}
Dim serializer As New JavaScriptSerializer()
Dim json = serializer.Serialize(result)
context.Response.ContentType = "application/json"
context.Response.ClearHeaders()
context.Response.Write(json)
context.Response.End()
'Return d
End Sub
ReadOnly Property IsReusable() As Boolean Implements IHttpHandler.IsReusable
Get
Return False
End Get
End Property
End Class
How to return dataset from this function it is giving error Unable to cast object of type 'Control' to type 'System.Collections.Generic.IEnumerable'.
Easiest way is to use a List() object. I would restructure your class
Public Class Control
Public LControl As New List(Of Control)
Public serialid As String
Public serialno As String
Public serialdesc As String
Public materialname As String
Public drawing As String
Public workorder As String
Public patno As String
Public result As String
End Class
​

How would I write formatted data to a file and then read it? VB.NET (2012 edition)

I'm practicing VB.NET and I've got a problem with Reading and writing to a .dat file. I have made a structure to store data temporarily (below).
Structure CustomerType
Dim AccountNum As String
Dim Surname As String
Dim Forename As String
Dim Balance As Decimal
End Structure
I then Dim everything.
Dim Customers(9) As CustomerType
Dim Filename As String = "Accounts.dat"
Dim NumberOfRecords As Short = 0
Dim myFormat As String = "{0,-15}|{1,-15}|{2,-10}|{3,-10}"
I have a button that creates a new account and this is where I get the problem.
FileOpen(1, Filename, OpenMode.Random, , , )
For i = 1 To Customers.Length() - 1
With Customers(i)
.Forename = InputBox("First name", "Forename")
Do Until .Forename <> "" And TypeOf .Forename Is String
.Forename = InputBox("First name", "Forename")
Loop
.Surname = InputBox("Surname", "Surname")
Do Until .Surname <> "" And TypeOf .Surname Is String
.Surname = InputBox("Surname", "Surname")
Loop
.AccountNum = InputBox("Account Number of " & Customers(i).Forename & " " & Customers(i).Surname & ".", "Account Number")
Do Until .AccountNum.Length = 8 And TypeOf .AccountNum Is String
.AccountNum = InputBox("Account Number of " & Customers(i).Forename & " " & Customers(i).Surname & ".", "Account Number")
Loop
.Balance = InputBox("Balance of " & Customers(i).Forename & " " & Customers(i).Surname & ".", "Balance")
Do Until .Balance > -1
.Balance = InputBox("Balance of " & Customers(i).Forename & " " & Customers(i).Surname & ".", "Balance")
Loop
FilePut(1, Customers, NumberOfRecords + 1)
NumberOfRecords += 1
lblNumberOfRecords.Text = NumberOfRecords
End With
Next
FileClose(1)
I have another button that displays the data in a listbox. I can only get one item to display before I get a bad length error.
Dim Index As Integer
ListBox1.Items.Clear()
ListBox1.Items.Add(String.Format(myFormat, "Forename", "Surname", "Acc. Num.", "Balance"))
ListBox1.Items.Add("_____________________________________________________")
FileOpen(1, Filename, OpenMode.Random, , , )
For Index = 1 To NumberOfRecords
FileGet(1, Customers)
ListBox1.Items.Add(String.Format(myFormat, Customers(Index).Forename, Customers(Index).Surname, Customers(Index).AccountNum, Format(Customers(Index).Balance, "currency")))
Next Index
FileClose(1)
The main question that I have is What am I doing wrong, and how can I fix it?
Many Thanks in advance,
Jordan
First you'll need to import these namespaces:
Imports System.Runtime.Serialization
Imports System.Runtime.Serialization.Formatters.Binary
Imports System.IO
Model
Change your customertype model to this:
<Serializable()> _
Public Class CustomerType
Implements ISerializable
Public Sub New()
End Sub
Protected Sub New(info As SerializationInfo, context As StreamingContext)
Me.AccountNum = info.GetString("AccountNum")
Me.Surname = info.GetString("Surname")
Me.Forename = info.GetString("Forename")
Me.Balance = info.GetDecimal("Balance")
End Sub
Public AccountNum As String
Public Surname As String
Public Forename As String
Public Balance As Decimal
Public Sub GetObjectData(info As System.Runtime.Serialization.SerializationInfo, context As System.Runtime.Serialization.StreamingContext) Implements System.Runtime.Serialization.ISerializable.GetObjectData
info.AddValue("AccountNum", Me.AccountNum)
info.AddValue("Surname", Me.Surname)
info.AddValue("Forename", Me.Forename)
info.AddValue("Balance", Me.Balance)
End Sub
End Class
Your model do now support serialization. Next step is to create functions to read/write a model collection to/from a file.
Write
Friend Shared Sub Write(filePathAndName As String, list As List(Of CustomerType))
Dim formatter As IFormatter = New BinaryFormatter()
Using stream As New FileStream(filePathAndName, FileMode.Create, FileAccess.Write, FileShare.None)
formatter.Serialize(stream, list)
End Using
End Sub
Read
Friend Shared Function Read(filePathAndName As String) As List(Of CustomerType)
Dim formatter As IFormatter = New BinaryFormatter()
Dim list As List(Of CustomerType) = Nothing
Using stream As New FileStream(filePathAndName, FileMode.Open, FileAccess.Read, FileShare.None)
list = DirectCast(formatter.Deserialize(stream), List(Of CustomerType))
End Using
Return list
End Function
Usage
Drop a button named Button1 onto a form named Form1 and add this code:
Public Class Form1
Public Sub New()
Me.InitializeComponent()
End Sub
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim path As String = "C:\test.dat" '<- Change to desired path
Dim list As New List(Of CustomerType)
'Create test item1 and add to list.
Dim item1 As New CustomerType()
With item1
.AccountNum = "1"
.Balance = 1000D
.Forename = "Forename 1"
.Surname = "Surname 1"
End With
list.Add(item1)
'Create test item2 and add to list.
Dim item2 As New CustomerType()
With item2
.AccountNum = "2"
.Balance = 2000D
.Forename = "Forename 2"
.Surname = "Surname 2"
End With
list.Add(item2)
'Write to file:
Write(path, list)
'Read from file into new list:
Dim list2 As List(Of CustomerType) = Read(path)
MsgBox(String.Format("Count={0}", list2.Count))
End Sub
Friend Shared Sub Write(filePathAndName As String, list As List(Of CustomerType))
Dim formatter As IFormatter = New BinaryFormatter()
Using stream As New FileStream(filePathAndName, FileMode.Create, FileAccess.Write, FileShare.None)
formatter.Serialize(stream, list)
End Using
End Sub
Friend Shared Function Read(filePathAndName As String) As List(Of CustomerType)
Dim formatter As IFormatter = New BinaryFormatter()
Dim list As List(Of CustomerType) = Nothing
Using stream As New FileStream(filePathAndName, FileMode.Open, FileAccess.Read, FileShare.None)
list = DirectCast(formatter.Deserialize(stream), List(Of CustomerType))
End Using
Return list
End Function
End Class

asp.net vb website loop through database rows

I am working on my first website and need help with a loop. I have a database table containing food items named Menu with 8 categories (such as Burgers, Appetizers). I also have a menu page on website with 8 different pics to display items from each category. I need to loop through rows of database. What is happening is it's only looping through columns and repeating first line over and over. I'm aware I need a loop but for some reason cannot get that right.
This is code behind:
Partial Class Burger
Inherits System.Web.UI.Page
'String Used to build the necessary markup and product information
Dim str As String = ""
'Var used to interact with SQL database
Dim db As New Interaction
'Adds the necessary markup for each menu item, using its productName
Protected Sub printMenuBlock(ByVal productName As String)
'Set up variable storing the product
Dim product As Product
'Pull the product in from our database using the productName
product = db.ReadProduct(productName)
'Add necessary markup to str variable, with products information within
str += "<div class='storeItem'>"
' str += " <img alt='Item Picture' class='itemPicture' src='" + product.ImagePath.Substring(3).Replace("\", "/") + "' />"
' str += " <div class='itemInfo'>"
str += " <h1 class='itemName'>"
str += " " + product.Name + "</h1>"
str += " <h3 class='itemDescription'>"
str += " " + product.Description + "</h3>"
str += " <p class='itemPrice'>"
str += " " + product.Price.ToString("c") + "</p>"
str += " "
str += " </div>"
str += " </div>"
End Sub
'Uses
Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
Dim productNames As New List(Of String)
'Pull the product names using the database
productNames = db.getProductNames
'Loop through all product names
For Each name As String In productNames
'Add necessary markup and product info to str variable
printMenuBlock(name)
Next
'Print the str variable in our menuPlace div
menuPlace.InnerHtml = str
End Sub
End Class
This is functions from interaction class:
Private Sub GetProduct(ByVal CatIn As String)
' SQL String
Dim strSelect As String
strSelect = "SELECT * "
strSelect &= " FROM Menu "
' strSelect &= " WHERE (ProductCat = 'Burgers')"
' Set up the connection to the datebase
cmdSelect.Connection = conIn.Connect
' Add the SQL string to the connection
cmdSelect.CommandText = strSelect
' Add the parameters to the connection
cmdSelect.Parameters.Add("#CatIn", SqlDbType.NVarChar).Value = CatIn
End Sub
'Executes the SQL statement to find a Product by ProductId
Public Function ReadProduct(ByVal CatIn As String) As Product
' Product object initalized to nothing
Dim prod As Product = Nothing
Try
Call GetProduct(CatIn)
Dim dbr As SqlDataReader
Dim strCat As String
Dim strName As String
Dim strDesc As String
Dim decPrice As Decimal
Dim strPath As String
' Execute the created SQL command from GetProduct and set to the SqlDataReader object
dbr = cmdSelect.ExecuteReader
dbr.Read()
' Check if there are any returned values
If dbr.HasRows Then
' Assign the value in column two to strName
strCat = dbr.GetString(1)
' Assign the value in column two to strName
strName = dbr.GetString(2)
' Assign the value in column three to strDesc
strDesc = dbr.GetString(3)
' Assing the value in column four to intPrice
decPrice = ToDecimal(dbr.GetValue(4))
'Assign the value in column five to strPath
'strPath = dbr.GetString(3)
' Create the new Product object from the returned values
prod = New Product(strName, strDesc, decPrice, strCat, strPath)
End If
' Clear the SQL parameters and close the connection
cmdSelect.Parameters.Clear()
dbr.Close()
Catch ex As SqlException
Dim strOut As String
strOut = ex.Message
Console.WriteLine(strOut)
End Try
' Return the Product object
Return prod
End Function
'Returns a list of Product Names
Public Function getProductNames() As List(Of String)
Dim list As New List(Of String)
Dim sql As String = "SELECT ProductName FROM Menu " +
"WHERE (ProductCat) = 'Burgers'"
'"DISTINCT 'ProductName'"
cmdSelect.CommandText = sql
cmdSelect.Connection = conIn.Connect
Dim dbr As SqlDataReader
dbr = cmdSelect.ExecuteReader
If dbr.HasRows Then
Do While dbr.Read()
list.Add(dbr.GetString(0))
Loop
End If
dbr.Close()
Return list
End Function
There is obviously a Product Class but don't think that is necessary to show on here.
Also, ignore the string path, that will be for images later. Thanks for any help. I'm pretty sure instead of do while I need a for each somewhere but just can't get her done. Thanks in advance.
Products Class:
Public Class Product
Private pName As String
Private pDescription As String
Private pPrice As Integer
Private pPath As String
Private pCat As String
'Constructor, uses database to populate properties based on productName
Public Sub New(ByVal productName As String)
Dim data As New Interaction
Dim work As Product
work = data.ReadProduct(productName)
pCat = work.Cat
pName = work.Name
pDescription = work.Description
pPrice = work.Price
End Sub
'Constructor, populates properties from passed in values
Public Sub New(ByVal NameIn As String,
ByVal DescriptionIn As String, ByVal PriceIn As Integer, ByVal CatIn As String, ByVal ImagePathIn As String)
pName = NameIn
pDescription = DescriptionIn
pPrice = PriceIn
pPath = ImagePathIn
pCat = CatIn
End Sub
'Stores name of product
Public ReadOnly Property Name() As String
Get
Return pName
End Get
End Property
'Stores a description of the product
Public ReadOnly Property Description() As String
Get
Return pDescription
End Get
End Property
'Stores the price of the product
Public ReadOnly Property Price() As Integer
Get
Return pPrice
End Get
End Property
'Stores the path to the image associated with this product
Public ReadOnly Property ImagePath() As String
Get
Return pPath
End Get
End Property
'Stores name of product
Public ReadOnly Property Cat() As String
Get
Return pCat
End Get
End Property
End Class
Use this instead
Public Function ReadProduct(ByVal CatIn As String) As List(Of Dictionary(String, Of String))
Dim ReturnProducts As New List(Of Dictionary(String, Of String))
Try
Call GetProduct(CatIn)
Dim dbr As SqlDataReader
' Execute the created SQL command from GetProduct and set to the SqlDataReader object
dbr = cmdSelect.ExecuteReader
Dim FieldCount = dbr.FieldCount()
Dim ColumnList as New List(Of String)
For i as Integer = 0 to FieldCount - 1
ColumnList.Add(dbr.GetName(i))
Next
While dbr.Read()
Dim ReturnProduct As New Dictionary(String, Of String)
For i as Integer = 0 to FieldCount - 1
ReturnProduct.Add(ColumnList(i), dbr.GetValue(i).toString())
Next
ReturnProducts.Add(ReturnProduct)
End While
cmdSelect.Parameters.Clear()
dbr.Close()
Catch ex As SqlException
Dim strOut As String
strOut = ex.Message
Console.WriteLine(strOut)
End Try
' Return the Product object
Return ReturnProducts
End Function
then, inside printMenuBlock, you declare product with
Dim product = db.ReadProduct(productName)
and later, you access it like so
For i as Integer = 0 to product.Count - 1
'do everything normally for building str except, for example, if you want
'to acccess product.Name as before, access it with product(i).Item("Name"),
'assuming that your column name/alias for "Name" is in fact "Name"
'i personally like to align column names to variable names for laziness's sake
'bad obfuscation practice tho if you don't use aliases
Next

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

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