CodeKeep VB.NET Feed

compare objects properties

Mon, 13 May 2013 13:25:22 GMT

Description: compare the values of properties of the two supplied objects

Link: http://www.codekeep.net/snippets/407e1d1b-f6f1-4146-aa04-a0c4e2ee8162.aspx

  ''' <summary>
        ''' Compares the properties of two objects of the same type and returns if all properties are equal.
        ''' </summary>
        ''' <param name="objectA">The first object to compare.</param>
        ''' <param name="objectB">The second object to compre.</param>
        ''' <param name="ignoreList">A list of property names to ignore from the comparison.</param>
        ''' <returns><c>true</c> if all property values are equal, otherwise <c>false</c>.</returns>
        Public Shared Function AreObjectsEqual(ByVal objectA As Object, ByVal objectB As Object, ByVal ParamArray ignoreList As String()) As Boolean
            Dim result As Boolean
            If objectA IsNot Nothing AndAlso objectB IsNot Nothing Then
                Dim objectType As Type
                objectType = objectA.[GetType]()
                result = True
                ' assume by default they are equal
                For Each propertyInfo As PropertyInfo In objectType.GetProperties(BindingFlags.[Public] Or BindingFlags.Instance).Where(Function(p) p.CanRead AndAlso Not ignoreList.Contains(p.Name))
                    Dim valueA As Object
                    Dim valueB As Object

                    valueA = propertyInfo.GetValue(objectA, Nothing)
                    valueB = propertyInfo.GetValue(objectB, Nothing)

                    ' if it is a primative type, value type or implements IComparable, just directly try and compare the value
                    If CanDirectlyCompare(propertyInfo.PropertyType) Then
                        If Not AreValuesEqual(valueA, valueB) Then
                            result = False
                        End If
                        ' if it implements IEnumerable, then scan any items
                    ElseIf GetType(IEnumerable).IsAssignableFrom(propertyInfo.PropertyType) Then
                        Dim collectionItems1 As IEnumerable(Of Object)
                        Dim collectionItems2 As IEnumerable(Of Object)
                        Dim collectionItemsCount1 As Integer
                        Dim collectionItemsCount2 As Integer
                        ' null check
                        If valueA Is Nothing AndAlso valueB IsNot Nothing OrElse valueA IsNot Nothing AndAlso valueB Is Nothing Then
                            result = False
                        ElseIf valueA IsNot Nothing AndAlso valueB IsNot Nothing Then
                            collectionItems1 = DirectCast(valueA, IEnumerable).Cast(Of Object)()
                            collectionItems2 = DirectCast(valueB, IEnumerable).Cast(Of Object)()
                            collectionItemsCount1 = collectionItems1.Count()
                            collectionItemsCount2 = collectionItems2.Count()

                            ' check the counts to ensure they match
                            If collectionItemsCount1 <> collectionItemsCount2 Then
                                result = False
                            Else
                                ' and if they do, compare each item... this assumes both collections have the same order
                                For i As Integer = 0 To collectionItemsCount1 - 1
                                    Dim collectionItem1 As Object
                                    Dim collectionItem2 As Object
                                    Dim collectionItemType As Type

                                    collectionItem1 = collectionItems1.ElementAt(i)
                                    collectionItem2 = collectionItems2.ElementAt(i)
                                    collectionItemType = collectionItem1.[GetType]()

                                    If CanDirectlyCompare(collectionItemType) Then
                                        If Not AreValuesEqual(collectionItem1, collectionItem2) Then
                                            result = False
                                        End If
                                    ElseIf Not AreObjectsEqual(collectionItem1, collectionItem2, ignoreList) Then
                                        result = False
                                    End If
                                Next
                            End If
                        End If
                    ElseIf propertyInfo.PropertyType.IsClass Then
                        If Not AreObjectsEqual(propertyInfo.GetValue(objectA, Nothing), propertyInfo.GetValue(objectB, Nothing), ignoreList) Then
                            result = False
                        End If
                    Else
                        result = False
                    End If
                Next
            Else
                result = Object.Equals(objectA, objectB)
            End If
            Return result
        End Function

        ''' <summary>
        ''' Determines whether value instances of the specified type can be directly compared.
        ''' </summary>
        ''' <param name="type">The type.</param>
        ''' <returns>
        '''   <c>true</c> if this value instances of the specified type can be directly compared; otherwise, <c>false</c>.
        ''' </returns>
        Private Shared Function CanDirectlyCompare(ByVal type As Type) As Boolean
            Return GetType(IComparable).IsAssignableFrom(type) OrElse type.IsPrimitive OrElse type.IsValueType
        End Function

        ''' <summary>
        ''' Compares two values and returns if they are the same.
        ''' </summary>
        ''' <param name="valueA">The first value to compare.</param>
        ''' <param name="valueB">The second value to compare.</param>
        ''' <returns><c>true</c> if both values match, otherwise <c>false</c>.</returns>
        Private Shared Function AreValuesEqual(ByVal valueA As Object, ByVal valueB As Object) As Boolean
            Dim result As Boolean
            Dim selfValueComparer As IComparable

            selfValueComparer = TryCast(valueA, IComparable)
            If valueA Is Nothing AndAlso valueB IsNot Nothing OrElse valueA IsNot Nothing AndAlso valueB Is Nothing Then
                result = False
                ' one of the values is null
            ElseIf selfValueComparer IsNot Nothing AndAlso selfValueComparer.CompareTo(valueB) <> 0 Then
                result = False
                ' the comparison using IComparable failed
            ElseIf Not Object.Equals(valueA, valueB) Then
                result = False
            Else
                ' the comparison using Equals failed
                result = True
            End If
            ' match
            Return result
        End Function

LINQ - Datatables

Wed, 30 Jan 2013 06:00:00 GMT

Description: Example of working with data-tables and linq

Link: http://www.codekeep.net/snippets/eda8ed76-5681-4360-a4c5-292127193809.aspx

           
Dim productPrices As IEnumerable(Of ProductCurrencyRate)

productPrices = From product In Me._listdata.Tables("Product").AsEnumerable

                Join prices In Me._listdata.Tables("ProductPrices").AsEnumerable
                    On prices.Field(Of Integer)("Product_ID") Equals product.Field(Of Integer)("Product_ID")

                Join collection In Me._listdata.Tables("ProductPriceCollection").AsEnumerable
                    On collection.Field(Of Integer)("ProductPrices_ID") Equals prices.Field(Of Integer)("ProductPrices_ID")

                Join currency In Me._listdata.Tables("ProductPriceByCurrency").AsEnumerable
                    On currency.Field(Of Integer)("ProductPriceCollection_ID") Equals collection.Field(Of Integer)("ProductPriceCollection_ID")

                Select New ProductCurrencyRate With {.Quickref = product.Field(Of String)("PID"),
                                                     .Code = currency.Field(Of String)("Code"),
                                                     .UnitPrice = currency.Field(Of String)("UnitPrice"),
                                                     .PreviousPrice = currency.Field(Of String)("PreviousUnitPrice"),
                                                     .Tax = currency.Field(Of String)("Tax")}

dbcolumn

Mon, 26 Nov 2012 04:22:40 GMT

Description: need to lookinto

Link: http://www.codekeep.net/snippets/979c27dd-6a66-4b5d-b602-b5510b785405.aspx

Imports System
Imports System.Data
Imports System.Data.Common
Imports System.Data.OleDb

Namespace DataAccess

    Namespace MSAccess

        ''' <summary>
        ''' Holds the values of a OleDb database column
        ''' </summary>
        ''' <remarks></remarks>
        Public Class DbColumn

#Region "Enumerations"

            ''' <summary>
            ''' Contains a list of operators that can be used in queries
            ''' </summary>
            ''' <remarks>Mainly useful in WHERE clause of a query</remarks>
            Public Enum ConditionalOperator As Integer
                EqualTo = 1
                NotEqualTo = 2
                GreaterThan = 3
                Lessthan = 4
                GreaterThanEqualTo = 5
                LessThanEqualTo = 6
                StringLike = 7
                StringNotLike = 8
            End Enum

#End Region

#Region "Variables"



            Private strColumnName As String
            Private objColumnType As OleDbType
            Private objColumnValue As Object
            Private enmColumnCondition As ConditionalOperator
            Private objDirection As ParameterDirection
            Private intSize As Integer
            Private blnIsNullable As Boolean

#End Region

#Region "Properties"

            ''' <summary>
            ''' Gets or sets the conditional operator used to compare a value of a column
            ''' </summary>
            ''' <value>Any value as ConditionalOperator enum</value>
            ''' <returns>ConditionalOperator</returns>
            ''' <remarks></remarks>
            Public Property ColumnConditionalOperator() As ConditionalOperator
                Get
                    Return enmColumnCondition
                End Get
                Set(ByVal value As ConditionalOperator)
                    enmColumnCondition = value
                End Set
            End Property

            ''' <summary>
            ''' Gets or sets data type of the column
            ''' </summary>
            ''' <value>Any OleDbType</value>
            ''' <returns>OleDbType</returns>
            ''' <remarks></remarks>
            Public Property DbType() As OleDbType
                Get
                    Return objColumnType
                End Get
                Set(ByVal value As OleDbType)
                    objColumnType = value
                End Set
            End Property

            ''' <summary>
            ''' Gets or sets the data size defined for the column
            ''' </summary>
            ''' <value>Size of the column as integer</value>
            ''' <returns>Column size as integer</returns>
            ''' <remarks></remarks>
            Public Property Size() As Integer
                Get
                    Return intSize
                End Get
                Set(ByVal value As Integer)
                    intSize = value
                End Set
            End Property

            ''' <summary>
            ''' Gets or sets the name of the source column
            ''' </summary>
            ''' <value>Name of the column as string</value>
            ''' <returns>Name of the column as string</returns>
            ''' <remarks></remarks>
            Public Property SourceColumn() As String
                Get
                    Return strColumnName
                End Get
                Set(ByVal value As String)
                    strColumnName = value
                End Set
            End Property

            ''' <summary>
            ''' Gets or sets the value of the column
            ''' </summary>
            ''' <value>Value of the column as object</value>
            ''' <returns>Object</returns>
            ''' <remarks></remarks>
            Public Property Value() As Object
                Get
                    Return objColumnValue
                End Get
                Set(ByVal Value As Object)
                    objColumnValue = Value
                End Set
            End Property

            ''' <summary>
            ''' Gets or sets whether a column can be null or not null
            ''' </summary>
            ''' <value>Any boolean value</value>
            ''' <returns>Boolean</returns>
            ''' <remarks></remarks>
            Public Property IsNullable() As Boolean
                Get
                    Return blnIsNullable
                End Get
                Set(ByVal value As Boolean)
                    blnIsNullable = value
                End Set
            End Property

#End Region

        End Class

    End Namespace

End Namespace

SQLDB wrapper

Mon, 26 Nov 2012 04:19:32 GMT

Description: .net class to connect and manipulate sql server database

Link: http://www.codekeep.net/snippets/ff1d213d-5ed5-4f74-801f-6aefcb8bf299.aspx

''''Option of Inline queries is given in this version 3.2.2
''''Newly Added Functions/Properties/Enums
''''Functions: SetConnectionTimeOut, ExecuteNonQuery, GetDataTable
''''Properties: ConnectionTimeout, ConnectionString
''''Enums: DBCommandType
''''Modified Functions: GetDataSet, GetReader, ExecuteScalar

Imports System
Imports System.IO
Imports System.Xml
Imports System.Data.Common
Imports System.Text
Imports System.Configuration
Imports System.Data
Imports System.Data.SqlTypes
Imports System.Data.SqlClient
Imports System.Windows.Forms

Namespace DataAccess

    Namespace SQL
        ''' <summary>
        ''' Provides methods for manipulating SQL database
        ''' </summary>
        ''' <remarks></remarks>
        Public Class SQLDBWrapper


#Region "Enumerations"
            ''' <summary>
            ''' Type of command to be set to the Command object
            ''' </summary>
            ''' <remarks></remarks>
            Public Enum DBCommandType As Integer
                Text = CommandType.Text
                StoredProcedure = CommandType.StoredProcedure
            End Enum
#End Region

#Region "Variables"

            Private colTempParam As New List(Of SqlParameter) 'To hold parameters of stored procedure
            Private Command As SqlCommand = Nothing
            Private _CommandTimeout As Integer = 30
            Private _ConnectionTimeout As Integer = 120
            Private strConnectionString As String = String.Empty
            Private strOriginalConectionString As String = String.Empty

#End Region

#Region "Properties"
            ''' <summary>
            ''' Gets or sets the wait time for executing the command before terminating the 
            ''' attempt to execute a command and generating an error. Default timeout is 30 seconds.
            ''' A value of 0 indicates no limit which must be avoided.
            ''' </summary>
            ''' <value>Timeout in seconds</value>
            ''' <returns></returns>
            ''' <remarks></remarks>
            Public Property CommandTimeout() As Integer
                Get
                    Return _CommandTimeout
                End Get
                Set(ByVal value As Integer)
                    _CommandTimeout = value
                End Set
            End Property

            ''' <summary>
            ''' Gets or Sets the ConnectionTimeout property which specifies the amount of time (in seconds) 
            ''' that the server waits before disconnecting an inactive connection. 
            ''' Specify a value between 1 and 65535.
            ''' If a value outside of this range is specified, IIS uses the default of 120 seconds.
            ''' A value of 0 indicates no limit which must be avoided.
            ''' </summary>
            ''' <value></value>
            ''' <returns></returns>
            ''' <remarks></remarks>
            Public Property ConnectionTimeout() As Integer
                Get
                    Return _ConnectionTimeout
                End Get
                Set(ByVal value As Integer)
                    _ConnectionTimeout = value
                End Set
            End Property

            ''' <summary>
            ''' Gets the Connection String for the current connection
            ''' </summary>
            ''' <value></value>
            ''' <returns></returns>
            ''' <remarks></remarks>
            Public ReadOnly Property ConnectionString() As String
                Get
                    Return strConnectionString
                End Get
            End Property

#End Region

#Region "Constructors"

            ''' <summary>
            ''' Creates a connection for a given connection string or connection string name as in config file.
            ''' </summary>
            ''' <param name="Connection">Connection string name as in configuration file or actual connection string</param>
            ''' <remarks>Constuctor takes both Connection String Name or Connection String</remarks>
            Public Sub New(ByVal Connection As String)
                Dim strCon As String = Connection.Trim()

                Try
                    If strCon.Contains("Data Source") Then
                        strConnectionString = strCon
                    Else
                        strConnectionString = ConfigurationManager.ConnectionStrings(strCon).ToString()
                    End If
                    strOriginalConectionString = strConnectionString

                    SetConnectionTimeOut()
                Catch ex As Exception
                    Throw
                End Try

            End Sub

#End Region

#Region "Functions"

            ''' <summary>
            ''' Executes the stored procedure and returns the output parameters
            ''' </summary>
            ''' <param name="StoredProcedure">Name of the stored procedure</param>
            ''' <returns>Output Parameters as SortedList(Of String, String)</returns>
            ''' <remarks></remarks>
            Public Function ExecuteProcedure(ByVal StoredProcedure As String) As SortedList(Of String, Object)

                Dim intRowsAffected As Integer
                Dim colReturnValues As New SortedList(Of String, Object)
                Dim objConnection As SqlConnection = Nothing

                Try
                    SetConnectionTimeOut()
                    objConnection = New SqlConnection(strConnectionString)
                    objConnection.Open()

                    Command = New SqlCommand(StoredProcedure, objConnection)

                    With Command
                        .CommandType = CommandType.StoredProcedure
                        .CommandTimeout = Me.CommandTimeout
                    End With


                    If colTempParam.Count > 0 Then
                        Command.Parameters.AddRange(GetDbParam())
                        'Clears the parameters after adding them to 'Command' object
                        colTempParam.Clear()
                    End If

                    intRowsAffected = Command.ExecuteNonQuery()

                    For i As Integer = 0 To Command.Parameters.Count - 1
                        If Command.Parameters(i).Direction = ParameterDirection.Output Then
                            colReturnValues.Add(Command.Parameters(i).ParameterName, Command.Parameters(i).Value)
                        End If
                    Next

                    ' adds return value
                    colReturnValues.Add("ReturnValue", intRowsAffected)

                    Return colReturnValues

                Catch ex As Exception
                    Throw
                Finally
                    objConnection.Close()
                    colTempParam.Clear()
                    Command = Nothing
                End Try

            End Function

            ''' <summary>
            ''' Executes the Stored Procedure / Query String and returns the rows affected
            ''' </summary>
            ''' <param name="StoredProcedureOrSQLQuery"></param>
            ''' <returns></returns>
            ''' <remarks></remarks>
            Public Function ExecuteNonQuery(ByVal StoredProcedureOrSQLQuery As String, Optional ByVal CmdType As DBCommandType = DBCommandType.StoredProcedure) As SortedList(Of String, Object)
                Dim intRowsAffected As Integer
                Dim colReturnValues As New SortedList(Of String, Object)
                Dim objConnection As SqlConnection = Nothing

                Try
                    SetConnectionTimeOut()
                    objConnection = New SqlConnection(strConnectionString)
                    objConnection.Open()

                    Command = New SqlCommand(StoredProcedureOrSQLQuery, objConnection)

                    With Command
                        .CommandType = CmdType
                        .CommandTimeout = Me.CommandTimeout
                    End With


                    If colTempParam.Count > 0 Then
                        Command.Parameters.AddRange(GetDbParam())
                        'Clears the parameters after adding them to 'Command' object
                        colTempParam.Clear()
                    End If

                    intRowsAffected = Command.ExecuteNonQuery()

                    ' adds return value
                    colReturnValues.Add("ReturnValue", intRowsAffected)

                    Return colReturnValues

                Catch ex As Exception
                    Throw
                Finally
                    objConnection.Close()
                    colTempParam.Clear()
                    Command = Nothing
                End Try
            End Function

            ''' <summary>
            ''' Returns a dataset by executing the Stored Procedure / Query String
            ''' </summary>
            ''' <param name="StoredProcedureOrSQLQuery">Name of the stored procedure/ Query String</param>
            ''' <returns>Dataset</returns>
            ''' <remarks></remarks>
            Public Function GetDataSet(ByVal StoredProcedureOrSQLQuery As String, Optional ByVal CmdType As DBCommandType = DBCommandType.StoredProcedure) As DataSet

                Dim Adapter As SqlDataAdapter = Nothing
                Dim ds As New DataSet()
                Dim objConnection As SqlConnection = Nothing

                Try
                    SetConnectionTimeOut()
                    objConnection = New SqlConnection(strConnectionString)

                    Command = New SqlCommand(StoredProcedureOrSQLQuery, objConnection)
                    Command.CommandType = CmdType
                    Command.CommandTimeout = CommandTimeout

                    If colTempParam.Count > 0 Then
                        Command.Parameters.AddRange(GetDbParam())
                        'Clears the parameters after adding them to 'Command' object
                        colTempParam.Clear()
                    End If

                    Adapter = New SqlDataAdapter(Command)
                    Adapter.Fill(ds)
                    Return ds

                Catch ex As Exception
                    Throw
                Finally
                    objConnection.Close()
                    colTempParam.Clear()
                    Command = Nothing
                    Adapter = Nothing
                End Try

            End Function

            ''' <summary>
            ''' Returns Datatable from the Stored pProcedure / Query String
            ''' </summary>
            ''' <param name="StoredProcedureOrSQLQuery"></param>
            ''' <returns></returns>
            ''' <remarks></remarks>
            Public Function GetDataTable(ByVal StoredProcedureOrSQLQuery As String, Optional ByVal CmdType As DBCommandType = DBCommandType.StoredProcedure) As DataTable
                Try
                    Return GetDataSet(StoredProcedureOrSQLQuery, CmdType).Tables(0)
                Catch ex As Exception
                    Throw
                End Try

            End Function

            ''' <summary>
            ''' Executes the stored procedure / query string and returns the SqlDataReader which needs to be closed explicitly
            ''' </summary>
            ''' <param name="StoredProcedureOrSQLQuery">Name of the stored procedure or Query String</param>
            ''' <returns>SqlDataReader</returns>
            ''' <remarks>
            ''' Reader should be explicitly closed after it finishes. 
            ''' Closing the reader causes the connection to be closed and returned to the connection pool.
            ''' </remarks>
            Public Function GetReader(ByVal StoredProcedureOrSQLQuery As String, Optional ByVal CmdType As DBCommandType = DBCommandType.StoredProcedure) As SqlDataReader
                Dim objConnection As SqlConnection = Nothing
                Try
                    SetConnectionTimeOut()
                    objConnection = New SqlConnection(strConnectionString)
                    objConnection.Open()

                    Command = New SqlCommand(StoredProcedureOrSQLQuery, objConnection)
                    Command.CommandType = CmdType

                    If colTempParam.Count > 0 Then
                        Command.Parameters.AddRange(GetDbParam())
                        'Clears the parameters after adding them to 'Command' object
                        colTempParam.Clear()
                    End If

                    Return Command.ExecuteReader(CommandBehavior.CloseConnection)

                Catch ex As Exception
                    Throw
                Finally
                    colTempParam.Clear()
                    Command = Nothing
                End Try

            End Function

            ''' <summary>
            ''' Executes the stored procedure/query string and returns the first column of the first row from the result set
            ''' </summary>
            ''' <param name="StoredProcedureOrSQLQuery">Name of the stored procedure</param>
            ''' <returns>Object</returns>
            ''' <remarks></remarks>
            Public Function ExecuteScalar(ByVal StoredProcedureOrSQLQuery As String, Optional ByVal CmdType As DBCommandType = DBCommandType.StoredProcedure) As Object
                Dim objConnection As SqlConnection = Nothing

                Try
                    SetConnectionTimeOut()
                    objConnection = New SqlConnection(strConnectionString)
                    objConnection.Open()

                    Command = New SqlCommand(StoredProcedureOrSQLQuery, objConnection)
                    Command.CommandType = CmdType

                    If colTempParam.Count > 0 Then
                        Command.Parameters.AddRange(GetDbParam())
                        'Clears the parameters after adding them to 'Command' object
                        colTempParam.Clear()
                    End If

                    Return Command.ExecuteScalar()

                Catch ex As Exception
                    Throw
                Finally
                    objConnection.Close()
                    colTempParam.Clear()
                End Try

            End Function

            ''' <summary>
            ''' Executes the SQL scalar function and returns the value as object
            ''' </summary>
            ''' <param name="FunctionName">Name of the SQL User-Defined function</param>
            ''' <returns>Object</returns>
            ''' <remarks></remarks>
            Public Function ExecuteScalarFunction(ByVal FunctionName As String) As Object
                Dim strQuery As New StringBuilder("SELECT " + FunctionName + "(")
                Dim objConnection As SqlConnection = Nothing

                Try
                    If colTempParam.Count > 0 Then
                        For i As Integer = 0 To colTempParam.Count - 1
                            strQuery.Append(colTempParam.Item(i).ParameterName + ",")
                        Next
                        strQuery.Remove(strQuery.Length - 1, 1)
                    End If

                    strQuery.Append(")")

                    SetConnectionTimeOut()
                    objConnection = New SqlConnection(strConnectionString)
                    objConnection.Open()


                    Command = New SqlCommand(strQuery.ToString(), objConnection)
                    Command.CommandType = CommandType.Text

                    If colTempParam.Count > 0 Then
                        Command.Parameters.AddRange(GetDbParam())
                        'Clears the parameters after adding them to 'Command' object
                        colTempParam.Clear()
                    End If

                    Return Command.ExecuteScalar()

                Catch ex As Exception
                    Throw
                Finally
                    objConnection.Close()
                    colTempParam.Clear()
                    Command = Nothing
                End Try

            End Function

            ''' <summary>
            ''' Executes the SQL Table-Valued function and returns the result as dataset
            ''' </summary>
            ''' <param name="FunctionName">Name of the SQL User-Defined function</param>
            ''' <returns>Dataset</returns>
            ''' <remarks></remarks>
            Public Function ExecuteTableValuedFunction(ByVal FunctionName As String) As DataSet

                Dim strQuery As New StringBuilder("SELECT * FROM " + FunctionName + "(")
                Dim Adapter As SqlDataAdapter = Nothing
                Dim ds As New DataSet()
                Dim objConnection As SqlConnection = Nothing

                Try
                    If colTempParam.Count > 0 Then
                        For i As Integer = 0 To colTempParam.Count - 1
                            strQuery.Append(colTempParam.Item(i).ParameterName + ",")
                        Next
                        strQuery.Remove(strQuery.Length - 1, 1)
                    End If

                    strQuery.Append(")")

                    SetConnectionTimeOut()
                    objConnection = New SqlConnection(strConnectionString)


                    Command = New SqlCommand(strQuery.ToString(), objConnection)
                    Command.CommandType = CommandType.Text

                    If colTempParam.Count > 0 Then
                        Command.Parameters.AddRange(GetDbParam())
                        'Clears the parameters after adding them to 'Command' object
                        colTempParam.Clear()
                    End If

                    Adapter = New SqlDataAdapter(Command)
                    Adapter.Fill(ds)
                    Return ds

                Catch ex As Exception
                    Throw
                Finally
                    objConnection.Close()
                    colTempParam.Clear()
                    Command = Nothing
                    Adapter = Nothing
                End Try

            End Function

            ''' <summary>
            ''' Converts a dataset to XML format in memory and saves if required.
            ''' </summary>
            ''' <param name="Data">DataTable</param>
            ''' <param name="FilePath">Path of the file for saving the XML result.</param>
            ''' <returns>XML as String</returns>
            ''' <remarks></remarks>
            Public Function ConvertToXml(ByVal Data As DataSet, Optional ByVal FilePath As String = "") As String

                Try
                    Data.DataSetName = "Root"

                    For Each dc As DataColumn In Data.Tables(0).Columns
                        dc.ColumnMapping = MappingType.Attribute
                    Next

                    Return Data.GetXml()
                Catch ex As Exception
                    Throw
                End Try

            End Function

            ''' <summary>
            ''' Adds a parameter to the parameter collection of the command object
            ''' </summary>
            ''' <param name="ParamName">Name of the parameter</param>
            ''' <param name="ParamType">Data type of the parameter</param>
            ''' <param name="ParamValue">Value of the parameter</param>
            ''' <param name="ParamDirection">Direction of the parameter</param>
            ''' <param name="ParamSize">Size of the parameter (0 for input parameter and exact size for output parameter as defined in database)</param>
            ''' <remarks></remarks>
            Public Sub AddParameter(ByVal ParamName As String, ByVal ParamType As DbType, ByVal ParamValue As Object, _
            ByVal ParamDirection As ParameterDirection, ByVal ParamSize As Integer)
                Dim objParam As New SqlParameter

                ''Added
                If ParamName.StartsWith("@") = False Then
                    ParamName = "@" + ParamName
                End If

                With objParam
                    .ParameterName = ParamName
                    .DbType = ParamType

                    If ParamType = DbType.Xml Then
                        .Value = New SqlXml(New XmlTextReader(ParamValue.ToString(), XmlNodeType.Document, Nothing))
                    ElseIf ParamType = DbType.DateTime Or ParamType = DbType.Date Then
                        If (Not IsNothing(ParamValue)) AndAlso (Not ParamValue Is DBNull.Value) AndAlso IsDate(ParamValue) Then
                            .Value = Convert.ToDateTime(ParamValue).ToString("O")
                        Else
                            .Value = DBNull.Value
                        End If
                    Else
                        .Value = ParamValue
                    End If

                    .Direction = ParamDirection
                    .Size = ParamSize
                End With

                colTempParam.Add(objParam)

            End Sub

            Public Sub ClearParameters()
                If colTempParam Is Nothing Then Exit Sub
                colTempParam.Clear()
            End Sub

            ''' <summary>
            ''' Internal function for creating a parameter collection
            ''' </summary>
            ''' <returns>DbParameter Array</returns>
            ''' <remarks></remarks>
            Private Function GetDbParam() As DbParameter()
                Dim colParam(colTempParam.Count - 1) As SqlParameter

                For i As Integer = 0 To colTempParam.Count - 1
                    colParam(i) = colTempParam(i)
                Next

                Dim DbParam() As DbParameter = colParam
                Return DbParam
            End Function

            '''' <summary>
            '''' Sets connection timeout if its not specified in the ConnectionString
            '''' If the connection timeout is there in the string, it will compare and 
            '''' update the max value to the connection string.
            '''' </summary>
            '''' <remarks></remarks>
            'Private Sub SetConnectionTimeOut1()

            '    If strConnectionString.ToLower.Contains("timeout") = False Then
            '        If strConnectionString.EndsWith(";") = True Then
            '            strConnectionString = strConnectionString.Trim() & "timeout = " & _ConnectionTimeout
            '        Else
            '            strConnectionString = strConnectionString.Trim() & ";timeout = " & _ConnectionTimeout
            '        End If

            '    Else
            '        Dim strConString() As String = strConnectionString.Split(";")
            '        For Each str As String In strConString
            '            If str.ToLower.Contains("timeout") = True Then
            '                Dim strtimeout() As String = str.Split("=")
            '                If strtimeout.Length > 1 Then
            '                    If CInt(strtimeout(1)) < _ConnectionTimeout Then
            '                        strConnectionString = strConnectionString.Trim().Substring(0, strConnectionString.Trim().IndexOf("timeout"))
            '                        If strConnectionString.EndsWith(";") = True Then
            '                            strConnectionString = strConnectionString.Trim() & "Timeout = " & _ConnectionTimeout.ToString()
            '                        Else
            '                            strConnectionString = strConnectionString.Trim() & ";Timeout = " & _ConnectionTimeout.ToString()
            '                        End If

            '                    End If
            '                End If
            '            End If
            '        Next
            '    End If
            'End Sub

            ''' <summary>
            ''' Sets connection timeout if its not specified in the ConnectionString
            ''' If the connection timeout is there in the string, it will compare and 
            ''' update the max value to the connection string.
            ''' </summary>
            ''' <remarks></remarks>
            Private Sub SetConnectionTimeOut()
                Try
                    strConnectionString = strOriginalConectionString

                    If strConnectionString.ToLower.Contains("timeout") = False Then
                        If strConnectionString.EndsWith(";") = True Then
                            strConnectionString = strConnectionString.Trim() & "timeout = " & _ConnectionTimeout.ToString()
                        Else
                            strConnectionString = strConnectionString.Trim() & ";timeout = " & _ConnectionTimeout.ToString()
                        End If
                    End If
                Catch
                    Throw
                End Try
            End Sub


#End Region

        End Class

    End Namespace

End Namespace

file manager

Mon, 26 Nov 2012 04:13:35 GMT

Description: file manager which can be used for loging

Link: http://www.codekeep.net/snippets/f6af6ddb-c20f-477c-bf5a-3b154e5f7c4a.aspx

Public Class FileManager
    Implements IDisposable

#Region "Global Functions"
    Private sFileName As String

    Public Property FileName() As String
        Get
            Return sFileName
        End Get
        Set(ByVal value As String)
            sFileName = value
        End Set
    End Property

    Public Function FileExists() As Boolean
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        Return My.Computer.FileSystem.FileExists(sFileName)
    End Function
    Public Sub DeleteFile()
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        Call My.Computer.FileSystem.DeleteFile(sFileName)
    End Sub
    Public Sub Close()
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If Not oSR Is Nothing Then oSR.Close()
        If Not oSW Is Nothing Then oSW.Close()
    End Sub

    Public Sub New()

    End Sub
    Public Sub New(ByVal FileName As String)
        sFileName = FileName
    End Sub
#End Region
#Region "Reading Files"
    Private oSR As IO.StreamReader

    Public ReadOnly Property EOF() As Boolean
        Get
            If sFileName = "" Then Throw New Exception("Filename Not Specified")
            If Not FileExists() Then Throw New Exception("File does not exists")
            If oSR Is Nothing Then Throw New Exception("File not open for reading")
            Return oSR.EndOfStream
        End Get
    End Property

    Public Sub OpenTextFileForReading()
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")

        If Not oSR Is Nothing Then
            oSR.Close()
            oSR.Dispose()
            oSR = Nothing
        End If

        oSR = New IO.StreamReader(sFileName)
    End Sub
    Public Function ReadToEndOfFile() As String
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSR Is Nothing Then Throw New Exception("File not open for reading")

        Return oSR.ReadToEnd
    End Function
    Public Function ReadLine() As String
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSR Is Nothing Then Throw New Exception("File not open for reading")

        Return oSR.ReadLine()
    End Function
    Public Function Read() As Integer
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSR Is Nothing Then Throw New Exception("File not open for reading")

        Return oSR.Read()
    End Function
    Public Function Read(ByVal Buffer() As Char, ByVal StartPos As Integer, ByVal Length As Integer) As Integer
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSR Is Nothing Then Throw New Exception("File not open for reading")

        Return oSR.Read(Buffer, StartPos, Length)
    End Function
    Public Sub CloseReader()
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSR Is Nothing Then Throw New Exception("File not open for reading")

        oSR.Close()
    End Sub
#End Region
#Region "Writing Files"
    Private oSW As IO.StreamWriter

    Public Property AutoFlush() As Boolean
        Get
            If sFileName = "" Then Throw New Exception("Filename Not Specified")
            If Not FileExists() Then Throw New Exception("File does not exists")
            If oSW Is Nothing Then Throw New Exception("File not open for writing")

            Return oSW.AutoFlush
        End Get
        Set(ByVal value As Boolean)
            If sFileName = "" Then Throw New Exception("Filename Not Specified")
            If Not FileExists() Then Throw New Exception("File does not exists")
            If oSW Is Nothing Then Throw New Exception("File not open for writing")

            oSW.AutoFlush = value
        End Set
    End Property

    Public Sub OpenTextFileForWriting()
        Call OpenTextFileForWriting(False)
    End Sub
    Public Sub OpenTextFileForWriting(ByVal bAppend As Boolean)
        If sFileName = "" Then Throw New Exception("Filename Not Specified")

        If Not oSW Is Nothing Then
            oSW.Flush()
            oSW.Close()
            oSW.Dispose()
            oSW = Nothing
        End If

        oSW = New IO.StreamWriter(sFileName, bAppend)
    End Sub
    Public Sub WriteLine(ByVal InputText As String)
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSW Is Nothing Then Throw New Exception("File not open for writing")

        oSW.WriteLine(InputText)
    End Sub
    Public Sub Write(ByVal InputText As String)
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSW Is Nothing Then Throw New Exception("File not open for writing")

        oSW.Write(InputText)
    End Sub
    Public Sub Write(ByVal Buffer() As Char)
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSW Is Nothing Then Throw New Exception("File not open for writing")

        oSW.Write(Buffer)
    End Sub
    Public Sub WriteMemoryContentsToFile()
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSW Is Nothing Then Throw New Exception("File not open for writing")

        oSW.Flush()
    End Sub

    Public Sub CloseWriter()
        If sFileName = "" Then Throw New Exception("Filename Not Specified")
        If Not FileExists() Then Throw New Exception("File does not exists")
        If oSW Is Nothing Then Throw New Exception("File not open for writing")

        oSW.Close()
    End Sub
#End Region

#Region " IDisposable Support "
    Private disposedValue As Boolean = False        ' To detect redundant calls

    ' IDisposable
    Protected Overridable Sub Dispose(ByVal disposing As Boolean)
        If Not Me.disposedValue Then
            If disposing Then
                ' TODO: free other state (managed objects).
            End If

            ' TODO: free your own state (unmanaged objects).
            ' TODO: set large fields to null.
        End If
        Me.disposedValue = True
    End Sub

    ' This code added by Visual Basic to correctly implement the disposable pattern.
    Public Sub Dispose() Implements IDisposable.Dispose
        ' Do not change this code.  Put cleanup code in Dispose(ByVal disposing As Boolean) above.
        Dispose(True)
    End Sub
#End Region

    Protected Overrides Sub Finalize()
        Me.Close()
        MyBase.Finalize()
    End Sub
End Class

advanced text box with spell check functionality

Mon, 26 Nov 2012 03:35:48 GMT

Description: advanced text box with spell check functionality

Link: http://www.codekeep.net/snippets/368cdfdf-84e9-48d9-8a0e-1657136b6002.aspx

Imports System.Windows

Public Class AdvancedTextBox
	Private WithEvents wpfTB As System.Windows.Controls.TextBox

	Public Event TBPreviewKeyUp(ByVal sender As Object, ByVal e As System.Windows.Input.KeyEventArgs)
	Public Event TBPreviewKeyDown(ByVal sender As Object, ByVal e As System.Windows.Input.KeyEventArgs)

	Public Enum Scrollbar
		Auto = 0
		Disabled = 1
		Hidden = 2
		Visible
	End Enum
	Public Enum AlignText
		Left = 0
		Right = 1
		Center = 2
		Justify = 3
	End Enum
	Public Enum WrapText
		WrapWithOverflow = 0
		NoWrap = 1
		Wrap = 2
	End Enum

	Public Sub New()

		' This call is required by the designer.
		InitializeComponent()

		' Add any initialization after the InitializeComponent() call.

		'Create the text box
		wpfTB = New System.Windows.Controls.TextBox
		wpfTB.SpellCheck.IsEnabled = True
		wpfTB.AcceptsReturn = False
		wpfTB.VerticalScrollBarVisibility = Scrollbar.Hidden
		Me.ctrlHost.Child = wpfTB
	End Sub

	Public Overrides Property BackColor As System.Drawing.Color
		Get
			Return MyBase.BackColor
		End Get
		Set(ByVal value As System.Drawing.Color)
			MyBase.BackColor = value

			Dim oBrush As New Media.SolidColorBrush(Media.Color.FromArgb(value.A, value.R, value.G, value.B))
			wpfTB.Background = oBrush
		End Set
	End Property
	Public Overrides Property ForeColor As System.Drawing.Color
		Get
			Return MyBase.ForeColor
		End Get
		Set(ByVal value As System.Drawing.Color)
			MyBase.ForeColor = value

			Dim oBrush As New Media.SolidColorBrush(Media.Color.FromArgb(value.A, value.R, value.G, value.B))
			wpfTB.Background = oBrush
		End Set
	End Property
	Public Overrides Property Font As System.Drawing.Font
		Get
			Return MyBase.Font
		End Get
		Set(ByVal value As System.Drawing.Font)
			MyBase.Font = value

			Dim oFont As New Media.FontFamily(Font.FontFamily.Name)
			wpfTB.FontFamily = oFont
		End Set
	End Property
	Public Overrides Property Text As String
		Get
			Return wpfTB.Text
		End Get
		Set(ByVal value As String)
			wpfTB.Text = value
		End Set
	End Property

	Public Overloads Property Enabled As Boolean
		Get
			Return wpfTB.IsEnabled
		End Get
		Set(ByVal value As Boolean)
			wpfTB.IsEnabled = value
		End Set
	End Property

	Public Property TextAlignment As AlignText
		Get
			Return wpfTB.TextAlignment
		End Get
		Set(ByVal value As AlignText)
			wpfTB.TextAlignment = value
		End Set
	End Property
	Public Property AutoSpellCheck As Boolean
		Get
			Return wpfTB.SpellCheck.IsEnabled
		End Get
		Set(ByVal value As Boolean)
			wpfTB.SpellCheck.IsEnabled = value
		End Set
	End Property
	Public Property ScrollBars As ScrollBar
		Get
			Return wpfTB.VerticalScrollBarVisibility
		End Get
		Set(ByVal value As ScrollBar)
			wpfTB.VerticalScrollBarVisibility = value
		End Set
	End Property
	Public Property MultiLine As Boolean
		Get
			Return wpfTB.AcceptsReturn
		End Get
		Set(ByVal value As Boolean)
			wpfTB.AcceptsReturn = value
		End Set
	End Property
	Public Property [ReadOnly] As Boolean
		Get
			Return wpfTB.IsReadOnly
		End Get
		Set(ByVal value As Boolean)
			wpfTB.IsReadOnly = value
			wpfTB.IsReadOnlyCaretVisible = True
		End Set
	End Property
	Public Property MaxLength As Integer
		Get
			Return wpfTB.MaxLength
		End Get
		Set(ByVal value As Integer)
			If value > 32767 Then Throw New Exception("Max length cannot be greater than 32767 charactors")
			If value < 0 Then Throw New Exception("Max length cannot be less than 0 charactors")
			If value = 0 Then value = 32767
			wpfTB.MaxLength = value

		End Set
	End Property
	Public Property WordWrap As WrapText
		Get
			Return wpfTB.TextWrapping
		End Get
		Set(ByVal value As WrapText)
			wpfTB.TextWrapping = value
		End Set
	End Property

	''' <summary>
	''' Checks for any spelling errors in the control, returns true if errors exist
	''' </summary>
	''' <returns>Boolean</returns>
	''' <remarks></remarks>
	Public Function CheckSpelling() As Boolean
		Dim bSpellingState As Boolean
		Try
			bSpellingState = wpfTB.SpellCheck.IsEnabled
			wpfTB.SpellCheck.IsEnabled = True

			If wpfTB.GetNextSpellingErrorCharacterIndex(0, System.Windows.Documents.LogicalDirection.Forward) <> -1 Then
				wpfTB.SpellCheck.IsEnabled = bSpellingState
				Return True
			End If

			wpfTB.SpellCheck.IsEnabled = bSpellingState
			Return False

		Catch ex As Exception
			wpfTB.SpellCheck.IsEnabled = bSpellingState
			Throw
		End Try
	End Function

	Private Sub wpfTB_PreviewKeyDown(ByVal sender As Object, ByVal e As System.Windows.Input.KeyEventArgs) Handles wpfTB.PreviewKeyDown
		RaiseEvent TBPreviewKeyDown(sender, e)
	End Sub
	Private Sub wpfTB_PreviewKeyUp(ByVal sender As Object, ByVal e As System.Windows.Input.KeyEventArgs) Handles wpfTB.PreviewKeyUp
		RaiseEvent TBPreviewKeyUp(sender, e)
	End Sub
End Class

advanced text box with spell check functionality

Mon, 26 Nov 2012 03:35:43 GMT

Description: advanced text box with spell check functionality

Link: http://www.codekeep.net/snippets/c2781a2d-134f-47c6-93f1-d32402035d70.aspx

Imports System.Windows

Public Class AdvancedTextBox
	Private WithEvents wpfTB As System.Windows.Controls.TextBox

	Public Event TBPreviewKeyUp(ByVal sender As Object, ByVal e As System.Windows.Input.KeyEventArgs)
	Public Event TBPreviewKeyDown(ByVal sender As Object, ByVal e As System.Windows.Input.KeyEventArgs)

	Public Enum Scrollbar
		Auto = 0
		Disabled = 1
		Hidden = 2
		Visible
	End Enum
	Public Enum AlignText
		Left = 0
		Right = 1
		Center = 2
		Justify = 3
	End Enum
	Public Enum WrapText
		WrapWithOverflow = 0
		NoWrap = 1
		Wrap = 2
	End Enum

	Public Sub New()

		' This call is required by the designer.
		InitializeComponent()

		' Add any initialization after the InitializeComponent() call.

		'Create the text box
		wpfTB = New System.Windows.Controls.TextBox
		wpfTB.SpellCheck.IsEnabled = True
		wpfTB.AcceptsReturn = False
		wpfTB.VerticalScrollBarVisibility = Scrollbar.Hidden
		Me.ctrlHost.Child = wpfTB
	End Sub

	Public Overrides Property BackColor As System.Drawing.Color
		Get
			Return MyBase.BackColor
		End Get
		Set(ByVal value As System.Drawing.Color)
			MyBase.BackColor = value

			Dim oBrush As New Media.SolidColorBrush(Media.Color.FromArgb(value.A, value.R, value.G, value.B))
			wpfTB.Background = oBrush
		End Set
	End Property
	Public Overrides Property ForeColor As System.Drawing.Color
		Get
			Return MyBase.ForeColor
		End Get
		Set(ByVal value As System.Drawing.Color)
			MyBase.ForeColor = value

			Dim oBrush As New Media.SolidColorBrush(Media.Color.FromArgb(value.A, value.R, value.G, value.B))
			wpfTB.Background = oBrush
		End Set
	End Property
	Public Overrides Property Font As System.Drawing.Font
		Get
			Return MyBase.Font
		End Get
		Set(ByVal value As System.Drawing.Font)
			MyBase.Font = value

			Dim oFont As New Media.FontFamily(Font.FontFamily.Name)
			wpfTB.FontFamily = oFont
		End Set
	End Property
	Public Overrides Property Text As String
		Get
			Return wpfTB.Text
		End Get
		Set(ByVal value As String)
			wpfTB.Text = value
		End Set
	End Property

	Public Overloads Property Enabled As Boolean
		Get
			Return wpfTB.IsEnabled
		End Get
		Set(ByVal value As Boolean)
			wpfTB.IsEnabled = value
		End Set
	End Property

	Public Property TextAlignment As AlignText
		Get
			Return wpfTB.TextAlignment
		End Get
		Set(ByVal value As AlignText)
			wpfTB.TextAlignment = value
		End Set
	End Property
	Public Property AutoSpellCheck As Boolean
		Get
			Return wpfTB.SpellCheck.IsEnabled
		End Get
		Set(ByVal value As Boolean)
			wpfTB.SpellCheck.IsEnabled = value
		End Set
	End Property
	Public Property ScrollBars As ScrollBar
		Get
			Return wpfTB.VerticalScrollBarVisibility
		End Get
		Set(ByVal value As ScrollBar)
			wpfTB.VerticalScrollBarVisibility = value
		End Set
	End Property
	Public Property MultiLine As Boolean
		Get
			Return wpfTB.AcceptsReturn
		End Get
		Set(ByVal value As Boolean)
			wpfTB.AcceptsReturn = value
		End Set
	End Property
	Public Property [ReadOnly] As Boolean
		Get
			Return wpfTB.IsReadOnly
		End Get
		Set(ByVal value As Boolean)
			wpfTB.IsReadOnly = value
			wpfTB.IsReadOnlyCaretVisible = True
		End Set
	End Property
	Public Property MaxLength As Integer
		Get
			Return wpfTB.MaxLength
		End Get
		Set(ByVal value As Integer)
			If value > 32767 Then Throw New Exception("Max length cannot be greater than 32767 charactors")
			If value < 0 Then Throw New Exception("Max length cannot be less than 0 charactors")
			If value = 0 Then value = 32767
			wpfTB.MaxLength = value

		End Set
	End Property
	Public Property WordWrap As WrapText
		Get
			Return wpfTB.TextWrapping
		End Get
		Set(ByVal value As WrapText)
			wpfTB.TextWrapping = value
		End Set
	End Property

	''' <summary>
	''' Checks for any spelling errors in the control, returns true if errors exist
	''' </summary>
	''' <returns>Boolean</returns>
	''' <remarks></remarks>
	Public Function CheckSpelling() As Boolean
		Dim bSpellingState As Boolean
		Try
			bSpellingState = wpfTB.SpellCheck.IsEnabled
			wpfTB.SpellCheck.IsEnabled = True

			If wpfTB.GetNextSpellingErrorCharacterIndex(0, System.Windows.Documents.LogicalDirection.Forward) <> -1 Then
				wpfTB.SpellCheck.IsEnabled = bSpellingState
				Return True
			End If

			wpfTB.SpellCheck.IsEnabled = bSpellingState
			Return False

		Catch ex As Exception
			wpfTB.SpellCheck.IsEnabled = bSpellingState
			Throw
		End Try
	End Function

	Private Sub wpfTB_PreviewKeyDown(ByVal sender As Object, ByVal e As System.Windows.Input.KeyEventArgs) Handles wpfTB.PreviewKeyDown
		RaiseEvent TBPreviewKeyDown(sender, e)
	End Sub
	Private Sub wpfTB_PreviewKeyUp(ByVal sender As Object, ByVal e As System.Windows.Input.KeyEventArgs) Handles wpfTB.PreviewKeyUp
		RaiseEvent TBPreviewKeyUp(sender, e)
	End Sub
End Class

Get geo location from Google maps

Fri, 23 Nov 2012 23:49:25 GMT

Description: With this subroutine, you can query Google for the geo location of an address.

Link: http://www.codekeep.net/snippets/d715cb20-5d92-4244-aeb1-40971ccf454e.aspx

            Dim sResponseText As String, sReturn As String
            sReturn = "none"
            Dim objHttp As Object, sQuery As String
            System.Threading.Thread.Sleep(50)
            sQuery = "http://maps.google.com/maps/geo?q=" & address & "&output=csv&key=AIzaSyB203li36fO-J0ruc17LhqCyGbMpjqXpQE"
            objHttp = CreateObject("Msxml2.ServerXMLHTTP")
            objHttp.Open("GET", sQuery, False)
            objHttp.send()
            sResponseText = objHttp.ResponseText
            'gsLastLatLongResponseText = sResponseText
            objHttp = Nothing
            If Len(sResponseText) > 0 Then
                If sResponseText = "620,0,0,0" Then
                    'MsgBox(address & " NOT found")
                    System.Threading.Thread.Sleep(1000)
                End If
                'MsgBox(sResponseText)
            End If
            'txtInfo.Text = address & "  =  " & sResponseText
            'txtInfo.Refresh()
            Return sResponseText

xmlviewer

Tue, 20 Nov 2012 04:04:35 GMT

Description: It is an usercontrol to view xml data with tree view and a detail description view

Link: http://www.codekeep.net/snippets/133684b5-783f-4608-a28f-e6c01fa57973.aspx

Imports IBM.Data.ApplicationBlocks.db2
Imports IBM.Data.DB2

Public Class XMLViewer

    'Property holders
    Private iTotalNodeCount As Integer
	Private dTreeWidthPercent As Double		'Tree width as percentage of control width
	Private sInputFileXML As String				'XML input file name
	Private sOutputFileHTML As String			'HTML output file name
	Private sTopNodeName As String				'Name of parent node for tree
	Private oNames As New Collection			'Collection of renaming infromation for tags

	Private sXMLOrderInfoSQL As String
	Private sEnvironmentUserName As String
	Private sApplicationID As String

	Private oDB2Conn As DB2Connection = Nothing
	Private oSQLConn As SqlClient.SqlConnection = Nothing
    Private oWebFont As System.Drawing.Font

	'Array of full path names (to allow extra information with tree)
	Dim sFullPath() As String

	Public Property DB2Connection As DB2Connection
		Get
			Return oDB2Conn
		End Get
        Set(ByVal value As DB2Connection)
            oDB2Conn = value
        End Set
	End Property
	Public Property SQLDBConnection As SqlClient.SqlConnection
		Get
			Return oSQLConn
		End Get
		Set(ByVal value As SqlClient.SqlConnection)
			oSQLConn = value
		End Set
	End Property

	Public Overrides Property BackColor As System.Drawing.Color
		Get
			Return MyBase.BackColor
		End Get
		Set(ByVal value As System.Drawing.Color)
			MyBase.BackColor = value
			tvwTagTree.BackColor = BackColor
			lblValue.BackColor = BackColor
		End Set
	End Property
	Public Overrides Property ForeColor As System.Drawing.Color
		Get
			Return MyBase.ForeColor
		End Get
		Set(ByVal value As System.Drawing.Color)
			MyBase.ForeColor = value
			tvwTagTree.ForeColor = ForeColor
			lblValue.ForeColor = ForeColor
		End Set
	End Property
	Public Overrides Property Font As System.Drawing.Font
		Get
			Return MyBase.Font
		End Get
		Set(ByVal value As System.Drawing.Font)
			MyBase.Font = value
			lblValue.Font = Font
            tvwTagTree.Font = Font
            WebFont = value
		End Set
    End Property
    Public Property WebFont As System.Drawing.Font
        Get
            Return oWebFont
        End Get
        Set(ByVal value As System.Drawing.Font)
            oWebFont = value
        End Set
    End Property

	Public Property ApplicationID As String
		Get
			Return sApplicationID
		End Get
		Set(ByVal value As String)
			sApplicationID = value
		End Set
	End Property
	Public Property EnvironmentUserName As String
		Get
			Return sEnvironmentUserName
		End Get
		Set(ByVal value As String)
			sEnvironmentUserName = value
		End Set
	End Property
	Public Property XMLOrderInfoSQL As String
		Get
			Return sXMLOrderInfoSQL
		End Get
		Set(ByVal value As String)
			sXMLOrderInfoSQL = value
		End Set
	End Property
	Public Property TreeWidthPercent As Double
		Get
			Return dTreeWidthPercent
		End Get
		Set(ByVal value As Double)
			If value < 20 OrElse value > 80 Then
				Throw New Exception("Illegal Tree Width Percentage")
			Else
				dTreeWidthPercent = value
				ReloadLayout()
			End If
		End Set
	End Property
	Public Property InputFileXML As String
		Get
			Return sInputFileXML
		End Get
		Set(ByVal value As String)
			sInputFileXML = value.Trim
		End Set
	End Property
	Public Property OutputFileHTML As String
		Get
			Return sOutputFileHTML
		End Get
		Set(ByVal value As String)
			sOutputFileHTML = value.Trim
		End Set
	End Property
	Public Property TopNodeName As String
		Get
			Return sTopNodeName
		End Get
		Set(ByVal value As String)
			value = value.Trim
			If value = "" Then
				Throw New Exception("Top Node must be Named")
			Else
				sTopNodeName = value.Trim
			End If
		End Set
	End Property

	Public Sub New()

		' This call is required by the designer.
		InitializeComponent()

		' Add any initialization after the InitializeComponent() call.
		TreeWidthPercent = 25
		InputFileXML = ""
		OutputFileHTML = ""
		TopNodeName = "XML"
		XMLOrderInfoSQL = "SELECT XML_FIELD, DESCRIPTION FROM EMS.ACQ_FIELDS WHERE DISPLAY_ORDER > 0 ORDER BY DISPLAY_ORDER"
		oSQLConn = Nothing
		oDB2Conn = Nothing

		Call ReloadLayout()
	End Sub
	Public Sub ReloadLayout()
		Try
			Me.SuspendLayout()

			'Calculate tree position and size
			tvwTagTree.Left = 0
			tvwTagTree.Top = 0
			tvwTagTree.Width = ((Me.Width * TreeWidthPercent) \ 100)
			tvwTagTree.Height = Me.Height - 65

			'Calculate web browser position and size
			webXMLInformation.Left = tvwTagTree.Width + 8
			webXMLInformation.Top = 0
			webXMLInformation.Height = Me.Height
			webXMLInformation.Width = Me.Width - tvwTagTree.Width - 8

			'Calculate label position and size
			lblValue.Left = 0
			lblValue.Top = Me.Height - 57
			lblValue.Height = 57
			lblValue.Width = tvwTagTree.Width

			Me.ResumeLayout()
		Catch ex As Exception
			Throw
		End Try
	End Sub
	Public Sub PrintHTML()
		Try
			'Refresh HTML with no highlighted row
			Call BuildHTML(0)

			'Refresh web browser contents
			Call webXMLInformation.Refresh()

			'Print web browser contents
			Call webXMLInformation.ShowPrintDialog()

		Catch ex As Exception
			Throw
		End Try
	End Sub
	Public Sub AddAlias(ByVal AliasName As String, ByVal Tag As String)
		Try
			'Create new collection if needed
			If oNames Is Nothing Then oNames = New Collection

			'Add new alias
            If Not oNames.Contains(Tag.ToUpper) Then oNames.Add(AliasName, Tag.ToUpper)
		Catch ex As Exception
			Throw
		End Try
	End Sub
	Public Sub RenameXML()
		Try
			Dim oNode As TreeNode
			Dim sFullTag As String
			Dim sNewName As String

			'Prepare array to hold path names
            ReDim sFullPath(iTotalNodeCount)

			'Parse entire tree
            For iCnt As Integer = iTotalNodeCount To 1 Step -1

                'Get node
                oNode = tvwTagTree.Nodes.Find("Tag" & iCnt.ToString, True)(0)
                'Get full tree name
                sFullTag = oNode.FullPath.Substring(4)

                'Remove top node description
                'sFullTag = sFullTag.Substring(Len(TopNodeName) + 2).ToUpper
                'Store full tree name for ordering later
                sFullPath(iCnt) = sFullTag

                'Set default new name
                sNewName = "(" & oNode.Text & ")"
                'Get replacement name if it exists in the naming collection
                If oNames.Contains(sFullTag.ToUpper) Then sNewName = oNames(sFullTag)

                'Change name in tree
                oNode.Text = sNewName
            Next

        Catch ex As Exception
            Throw
        End Try
	End Sub

	Private Function ProcessXML(ByVal oNodes As Xml.XmlNode, ByRef sCurrentTag As String) As TreeNode
        Try

            Dim oParentNode As New TreeNode(oNodes.Name)
            oParentNode.Name = sCurrentTag


            For Each oNode As Xml.XmlNode In oNodes
                If oNode.Name = "#text" Then
                    oParentNode.Tag &= oNode.Value
                Else
                    iTotalNodeCount += 1
                    sCurrentTag = "Tag" & iTotalNodeCount.ToString
                    Dim oTNode As TreeNode = ProcessXML(oNode, sCurrentTag)
                    oParentNode.Nodes.Add(oTNode)
                End If
            Next

            Return oParentNode
        Catch ex As Exception
            Throw
        End Try
	End Function
	Public Sub ReadXML()
		Try
			Dim sCurrentTag As String = ""

			'Sort file error trapping out
			If InputFileXML = "" Then Throw New Exception("XML File was not specified")
			If Not My.Computer.FileSystem.FileExists(InputFileXML) Then Throw New Exception("XML file not found" & vbCr & vbCr & """" & InputFileXML & """")
			If InputFileXML.ToUpper = OutputFileHTML.ToUpper Then Throw New Exception("Input file and Output file are the same file")

			'Create progress bar
			Dim oPB As New ErrorHandler.HSBCProgressBar
			oPB.CaptionMain = "Loading XML"
			oPB.CaptionDetail = "Reading XML Document"

			'clear the tree
            tvwTagTree.Nodes.Clear()
            iTotalNodeCount = 0
            sCurrentTag = "Tag" & iTotalNodeCount.ToString

			'Add standard top node
			Dim oParentNode As New TreeNode(TopNodeName)
			oParentNode.Name = sCurrentTag

			'Read XML file into TreeView control and update control
			Dim oXML As New Xml.XmlDocument
			oXML.Load(InputFileXML)

			For Each oNode As Xml.XmlNode In oXML.ChildNodes
                If Not oNode Is oXML.FirstChild Then
                    iTotalNodeCount += 1
                    sCurrentTag = "Tag" & iTotalNodeCount.ToString
                    oParentNode.Nodes.Add(ProcessXML(oNode, sCurrentTag))
                End If
			Next

			tvwTagTree.Nodes.Add(oParentNode)

			'to finish rename the xml tags
			oPB.PerformStep("Renaming Tags")
			Call RenameXML()

			'Build the first HTML
			oPB.PerformStep("Building HTML")
			Call BuildHTML(0)

			'and navigate to it
			oPB.Close()
			oPB = Nothing

			Call webXMLInformation.Navigate(OutputFileHTML)

		Catch ex As Exception
			Throw
		End Try
	End Sub

	Private Sub BuildHTML(ByVal iHighlightTag As Integer)
        Try
            Dim iCnt As Integer = 0
            Dim oDT As New DataTable
            Dim sMatch As String = ""
            Dim sTableRow As String = ""

            'TODO: Get ordering information from database
            If Not oSQLConn Is Nothing Then
                Using oDA As New SqlClient.SqlDataAdapter(XMLOrderInfoSQL, oSQLConn)
                    oDA.Fill(oDT)
                End Using
            ElseIf Not oDB2Conn Is Nothing Then
                Using oDA As New DB2DataAdapter(XMLOrderInfoSQL, oDB2Conn)
                    oDA.Fill(oDT)
                End Using
            End If

            'Open HTML file
            Dim oFMan As New ErrorHandler.FileManager(OutputFileHTML)
            oFMan.OpenTextFileForWriting()
            oFMan.AutoFlush = False

            'Write HTML header lines
            oFMan.WriteLine("<html>")
            oFMan.WriteLine("<body style=""Font-Family:" & oWebFont.FontFamily.Name & """>")

            'Add Acquisition identifier of Acq_ID and user name
            oFMan.WriteLine("<h5> Application ID : " & ApplicationID & " <br> Current User ID : " & EnvironmentUserName & "</h5>")

            'Add title
            oFMan.WriteLine("<h1><a name=""Tag" & iCnt.ToString & """>" & TopNodeName & "</a></h1>")

            'Add table definition to HTML
            oFMan.WriteLine("<table>")
            oFMan.WriteMemoryContentsToFile()

            'Loop through each record in the ordering set
            For Each oRow As DataRow In oDT.Rows

                'Set string to xml field to stop continuous recordset access
                sMatch = oRow("XML_FIELD").ToString.Trim

                'Check if this record is a section header, denoted by an asterisk at the front of the description
                If oRow("Description").ToString.Substring(0, 1) = "*" Then
                    oFMan.WriteLine("<tr><td COLSPAN=2><font size=2 color=darkblue><u><b>" & oRow("Description").ToString.Trim.Substring(1, oRow("Description").ToString.Trim.Length - 1) & "</b></u></font><br></td></tr>")
                Else

                    For iCnt = 1 To iTotalNodeCount
                        'Check if node matches
                        If sFullPath(iCnt).ToUpper = sMatch.ToUpper Then

                            Dim oNode As TreeNode = tvwTagTree.Nodes.Find("Tag" & iCnt.ToString, True)(0)
                            If Not oNode Is Nothing Then

                                'Set highlight color for row
                                sTableRow = IIf(iCnt = iHighlightTag + 1, "<tr valign=center bgcolor=yellow>", "<tr valign=center>")

                                Dim sTag As String = ""
                                If Not oNode.Tag Is Nothing Then sTag = oNode.Tag.ToString

                                oFMan.WriteLine(sTableRow & "<td width=50% align=right><font size=2 color=" & _
                                 IIf(oNode.Nodes.Count = 0, "black", "darkblue") & _
                                 "><a name=""Tag" & iCnt.ToString & """>" & oNode.Text & _
                                 " :</a></font></td><td width=50% align=left><font size=2 color=blue>" & sTag.ToLower & _
                                 "</font>&nbsp;<br></td></tr>")

                                'Don't continue search for this xml field
                                Exit For
                            End If
                        End If
                    Next
                End If
                oFMan.WriteMemoryContentsToFile()
            Next

            'Write HTML footer lines
            oFMan.WriteLine("</table>")
            oFMan.WriteLine("</body>")
            oFMan.WriteLine("</html>")
            oFMan.WriteMemoryContentsToFile()

            'Close HTML file
            oFMan.CloseWriter()
            oFMan.Dispose()

            oFMan = Nothing
            oDT = Nothing

        Catch ex As Exception
            Throw
        End Try
	End Sub
	Private Sub tvwTagTree_NodeMouseClick(ByVal sender As Object, ByVal e As System.Windows.Forms.TreeNodeMouseClickEventArgs) Handles tvwTagTree.NodeMouseClick
		Try
			Dim sNodeKey As String
			'Build HTML document with correct highlight
            Call BuildHTML(CInt(Val(e.Node.Name.Substring(3))) - 1)

            'sNodeKey = CInt(Val(e.Node.Name.Substring(3)) + 1).ToString.Trim
            sNodeKey = CInt(Val(e.Node.Name.Substring(3))).ToString.Trim
			sNodeKey = "Tag" & sNodeKey

			'Browse to bookmark
			webXMLInformation.Refresh()
			webXMLInformation.Navigate(OutputFileHTML & "#" & sNodeKey)

			lblValue.Text = e.Node.Tag
		Catch ex As Exception
			Throw
		End Try
	End Sub
	Private Sub XMLViewer_Resize(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Resize
		Try
			ReloadLayout()
		Catch ex As Exception
			Throw
		End Try
	End Sub

	Private Function StandardiseEmptyTags(ByVal sXML As String) As String
		'Standardise empty tags by changing <SAMPLE/> to <SAMPLE></SAMPLE>

		Try
			Dim iEndPointer As Integer = 0
			Dim iStartPointer As Integer = 0
			Dim sTag As String = ""
			'Check for illegal use of unnamed tags
			If sXML.Contains("</>") Then Throw New Exception("Illegal XML" & ControlChars.CrLf & ControlChars.CrLf & "Unnamed tag(s) exist")

			'Find empty tag
			iEndPointer = sXML.IndexOf("/>")

			'Loop until all empty tags are changed
			Do While iEndPointer > 0

				'Find start position of tag
				For iStartPointer = iEndPointer To 0 Step -1

					'Check for < not found
					If iStartPointer = 0 Then Throw New Exception("Illegal XML" & vbCr & vbCr & """/>"" without ""<""")

					'Check for < found
					If sXML.Substring(iStartPointer, 1) = "<" Then Exit For
				Next

				'Start of tag found, get tag name
				sTag = sXML.Substring(iStartPointer + 1, iEndPointer - iStartPointer - 1) = "<"

				'Modify XML
				sXML = Strings.Left(sXML, iStartPointer) & sTag & "></" & sTag & sXML.Substring(iEndPointer + 1)

				'Find next empty tag
				iEndPointer = sXML.IndexOf("/>")
			Loop

			'Return update XML
			Return sXML

		Catch ex As Exception
			Throw
		End Try
	End Function

End Class

API SuspendLayout

Tue, 31 Jul 2012 14:54:21 GMT

Description:

Link: http://www.codekeep.net/snippets/1ca25ba6-6544-4c06-85b6-e41be82a3cd8.aspx


#Region "Constantes API"	
    Private Const SE_ERR_FNF As Short = 2
    Private Const SE_ERR_PNF As Short = 3
    Private Const SE_ERR_ACCESSDENIED As Short = 5
    Private Const SE_ERR_OOM As Short = 8
    Private Const SE_ERR_DLLNOTFOUND As Short = 32
    Private Const SE_ERR_SHARE As Short = 26
    Private Const SE_ERR_ASSOCINCOMPLETE As Short = 27
    Private Const SE_ERR_DDETIMEOUT As Short = 28
    Private Const SE_ERR_DDEFAIL As Short = 29
    Private Const SE_ERR_DDEBUSY As Short = 30
    Private Const SE_ERR_NOASSOC As Short = 31
    Private Const ERROR_BAD_FORMAT As Short = 11

    'Cursor constants
    Private Const IDC_APPSTARTING As UInt32 = 32650
    Private Const IDC_ARROW As UInt32 = 32512
    Private Const IDC_HAND As UInt32 = 32649
    Private Const IDC_CROSS As UInt32 = 32515
    Private Const IDC_HELP As UInt32 = 32651
    Private Const IDC_IBEAM As UInt32 = 32513
    Private Const IDC_NO As UInt32 = 32648
    Private Const IDC_SIZEALL As UInt32 = 32646
    Private Const IDC_SIZENESW As UInt32 = 32643
    Private Const IDC_SIZENS As UInt32 = 32645
    Private Const IDC_SIZENWSE As UInt32 = 32642
    Private Const IDC_SIZEWE As UInt32 = 32644
    Private Const IDC_UP As UInt32 = 32516
    Private Const IDC_WAIT As UInt32 = 32514
    Private Const SPI_SETCURSORS = 87
    Private Const SPIF_SENDWININICHANGE = &H2
    Private Const SPIF_UPDATEINIFILE = &H1
    Const WM_SETREDRAW As Integer = &HB
    Const WM_USER As Integer = &H400
    Const EM_GETEVENTMASK As Integer = (WM_USER + 59)
    Const EM_SETEVENTMASK As Integer = (WM_USER + 69)


    Private Declare Auto Function SendMessage Lib "user32.dll" _
        (ByVal hWnd As IntPtr, ByVal wMsg As Int32, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
#End Region

student exam rank

Wed, 25 Jul 2012 03:35:40 GMT

Description: student exam rank

Link: http://www.codekeep.net/snippets/6fe16895-c197-4dc2-80f8-2a43f641e5d2.aspx

 Private Sub ExamRank()
        Try
            Dim sql As String = _
       "SELECT student,dense_rank() OVER (ORDER BY percentage DESC) as 'Rank' " & _
       "FROM examresult " & _
       "WHERE acayear='" & academic_year & "' and gcode='" & cmbGrp.SelectedValue & "' and exam='" & cmbTerm.SelectedValue & "' and examtype='1'"
            Dim dt As DataTable = SchoolDB.GetDataTable(sql)
            If Not dt Is Nothing And dt.Rows.Count > 0 Then
                For Each row As DataRow In dt.Rows
                    Dim stid As String = row.Item("student")
                    Dim rank As String = row.Item("rank")
                    'update rank
                    sql = "UPDATE examresult SET rank='" & rank & "' " & _
                    "WHERE student='" & stid & "' and acayear='" & academic_year & "' and gcode='" & cmbGrp.SelectedValue & "' and exam='" & cmbTerm.SelectedValue & "' and examtype='1'"
                    dt = SchoolDB.GetDataTable(sql)
                Next
            End If
            'MsgBox("", MsgBoxStyle.Information)
        Catch ex As Exception

        End Try
       

    End Sub

Shell - determine 32 or 64 bit program

Fri, 13 Jul 2012 15:51:23 GMT

Description: If the Excel version is 2007 the need to determine the operating system.

Link: http://www.codekeep.net/snippets/7854a71d-9cb7-464e-b96c-2a21225ee2fc.aspx

 Public Sub OpenInstructions()
        Try
            Shell("C:\Program Files\Microsoft Office\Office11\WINWORD.EXE ""C:\Documents and Settings\" & strUserName & "\Desktop\PIPELINE PROGRAM INSTRUCTIONS1.1.docx""", AppWinStyle.NormalFocus)
        Catch ex As Exception
            Try
                Shell("C:\Program Files (x86)\Microsoft Office\Office12\WINWORD.EXE ""C:\Documents and Settings\" & strUserName & "\Desktop\PIPELINE PROGRAM INSTRUCTIONS1.1.docx""", AppWinStyle.NormalFocus)
            Catch ex2 As Exception
                Shell("C:\Program Files\Microsoft Office\Office12\WINWORD.EXE ""C:\Documents and Settings\" & strUserName & "\Desktop\PIPELINE PROGRAM INSTRUCTIONS1.1.docx""", AppWinStyle.NormalFocus)
            End Try
        End Try

Initialise HTTPContext for unit testing

Thu, 05 Jul 2012 04:42:25 GMT

Description: Creates a HTTPContext.Current for use in unit testing a web app

Link: http://www.codekeep.net/snippets/4ccbfe7e-ceb0-40de-bf37-6f6e2e00d749.aspx

        Dim tw As TextWriter = New StringWriter
        Dim wr As New SimpleWorkerRequest("/webapp", "C:\\inetpub\\wwwroot\\webapp\\", "default.aspx", "", tw)

        HttpContext.Current = New HttpContext(wr)

        If HttpContext.Current.Items("DataContextFactory") Is Nothing Then
            Dim dc As DataContextFactory = New DataContextFactory(System.Configuration.ConfigurationManager.ConnectionStrings("EntitiesDataContext").ConnectionString)
            HttpContext.Current.Items.Add("DataContextFactory", dc)
        End If

AddHandler

Fri, 15 Jun 2012 15:48:23 GMT

Description: Using a AddHandler to raise an event - see the ClickOnceEquipmentRental program on the MultiChecking form. cmdChangeDaysOut_Click event raises a form to change the date and then Enter returns to the MultiCheckin form.

Link: http://www.codekeep.net/snippets/29005590-2b40-4238-a8a7-16c180f8b527.aspx

 Private Sub MultipleCheckin_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        txtCheckInDate.Text = Date.Today.ToString("d")
        txtCheckInDate.Focus()
        rentals.Clear()
        totals.Clear()
        display.Clear()
        pnl_CheckIn.Hide()
        pnl_Order.Hide()
        AddHandler EnterCheckinDate.CheckinDateEntered, AddressOf Me.CheckinDateEntered
        AddHandler ChangeCheckoutDate.ChangeCheckoutDateEntered, AddressOf Me.ChangeCheckoutDateEntered
        AddHandler ChangeCheckinDate.ChangeCheckinDateEntered, AddressOf Me.ChangeCheckinDateEntered
        AddHandler ChangeSearchCriteria.Changesearch, AddressOf Me.ChangeSearch
        AddHandler ChangeShipTo.ChangeAddressEntered, AddressOf Me.ChangeAddressEntered
        AddHandler ctrlFindForm.ControlfindEntered, AddressOf Me.ControlFindEntered
end sub


    Private Sub cmdChangeDaysOut_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdChangeDaysOut.Click
        _Yes = MsgBox("Caution this will change ALL the rental items timeout days. Are you sure?", MsgBoxStyle.YesNoCancel)
        If _Yes <> MsgBoxResult.Yes Then Exit Sub
        ChangeCheckoutDate.ShowDialog()
    End Sub

'********** the next lines are the class of the form raised on the button click.
Public Class ChangeCheckoutDate
    Delegate Sub ChangeCheckoutDateEnteredHandler(ByVal e As changeCheckoutDateEventArgs)
    Public Event ChangeCheckoutDateEntered As ChangeCheckoutDateEnteredHandler
    Private Sub ChangeCheckoutDate_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing

    End Sub
    Private Sub cmd_Enter_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmd_Enter.Click
        Try
            Dim dt As DateTime
            dt = CType(txt_CheckoutDate.Text, DateTime)
            RaiseEvent ChangeCheckoutDateEntered(New changeCheckoutDateEventArgs(dt))
            Me.Close()
        Catch ex As Exception
            MsgBox(ex.Message)
        End Try

    End Sub

    Public Class changeCheckoutDateEventArgs
        Inherits System.EventArgs

        Private _DateEntered As DateTime
        Public Property DateEntered() As DateTime
            Get
                Return Me._DateEntered
            End Get
            Set(ByVal value As DateTime)
                Me._DateEntered = value
            End Set
        End Property
        Sub New()
            MyBase.New()
        End Sub
        Sub New(ByVal dateEntered As DateTime)
            MyBase.New()
            Me._DateEntered = dateEntered
        End Sub
    End Class
    Private Sub ToPicker_ValueChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ToPicker.ValueChanged
        Dim _from As Date = ToPicker.Text
        txt_CheckoutDate.Text = _from
    End Sub
    Private Sub ChangeCheckoutDate_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        If txt_CheckoutDate.Text = "" Then
            txt_CheckoutDate.Text = Date.Today.ToString("d")
        End If

    End Sub
End Class

XML to FTP

Fri, 15 Jun 2012 14:04:26 GMT

Description: Writing a table in XML to a FTP site

Link: http://www.codekeep.net/snippets/23f263bc-320e-4025-abe3-ce7d14513f69.aspx

Imports System.IO
Imports EnterpriseDT.Net.Ftp
Imports Microsoft.VisualBasic    

Private Structure FTPInfo
        Public UserName As String
        Public Password As String
        Public Host As String
    End Structure

Private Sub ExportXML()
        'Dim objDataSet As New System.Data.DataSet("AmtechToASW")
        'Dim objXmlDocument As New System.Xml.XmlDocument
        'Dim objCmd As System.Data.OleDb.OleDbDataAdapter
        'Dim str As String
        'Dim openedconn As Boolean = False

        'Try


        'If oledbObjConn.State = ConnectionState.Closed Then
        '    oledbObjConn.Open()
        '    openedconn = True
        'End If
        'str = "SELECT * FROM tblRentalASW"
        'objCmd = New System.Data.OleDb.OleDbDataAdapter(str, oledbObjConn)
        'objCmd.Fill(objDataSet, "tblRentalASW")

        'str = "SELECT * FROM tblRentalASW"
        'objCmd = New System.Data.OleDb.OleDbDataAdapter(str, oledbObjConn)
        'objCmd.Fill(objDataSet, "tblRentalASW")

        'oledbObjConn.Close()

        'objXmlDocument.LoadXml(objDataSet.GetXml())

        'If File.Exists(xmlFile) Then
        '    File.Delete(xmlFile)
        'End If
        '    objXmlDocument.Save(xmlFile)
        'Catch ex As Exception
        '    MsgBox("There was an error: " & ex.Message & ex.StackTrace)
        'Finally
        '    If openedconn Then oledbObjConn.Close()
        'End Try

        'Dim poNum As String
        'Dim jobNum As String
        'Dim filename As String


        Dim str As String
        Dim f As System.IO.File
        Dim fso As System.IO.StreamWriter
        'need to get the customer information for the header            

        If File.Exists(xmlFile) Then
            File.Delete(xmlFile)
        End If

        fso = f.CreateText(xmlFile)

        fso.WriteLine("<?xml version=""1.0"" encoding=""UTF-8""?>")
        fso.WriteLine("<ASWNotifier>")
        fso.WriteLine("    <Invoices>")
        GetInvoices(fso)
        fso.WriteLine("    </Invoices>")
        fso.WriteLine("</ASWNotifier>")
        fso.Close()


    End Sub

    Private Sub GetInvoices(ByRef fso As StreamWriter)
        Dim str As String = "SELECT tblInvoicePerm.*, tblAddress.AddressCode, tblAddress.Address, tblAddress.City, tblAddress.State, tblAddress.Zip, tblAddress.AddressCode, tblAddress.Contact, tblAddress.Phone, tblCustomer.Customer, tblCustomer.RepCode " _
        & " FROM (tblInvoicePerm LEFT JOIN tblAddress ON tblInvoicePerm.AddressCode = tblAddress.AddressCode) " _
        & " LEFT JOIN tblCustomer ON tblInvoicePerm.CustNum = tblCustomer.CustNum;"
        Dim cmd As OleDb.OleDbCommand
        Dim rs As OleDb.OleDbDataReader
        Dim invoice As InvoiceInfo
        Dim invoiceArr As New ArrayList
        Dim openedconn As Boolean = False

        Try
            If oledbObjConn.State = ConnectionState.Closed Then
                oledbObjConn.Open()
                openedconn = True
            End If
            cmd = New OleDb.OleDbCommand(str, oledbObjConn)
            rs = cmd.ExecuteReader()

            While rs.Read
                invoice = New InvoiceInfo
                'Add in all the invoice information for the ship to address
                invoice.invoiceNum = rs("InvoiceNum")
                invoice.orderNum = rs("OrderNum")
                invoice.customer = rs("Customer")
                invoice.invoiceDate = rs("InvoiceDate")
                invoice.custNum = rs("CustNum")
                invoice.address = rs("address")
                invoice.city = rs("city")
                invoice.state = rs("state")
                invoice.zip = rs("zip")
                invoice.phone = rs("phone")
                invoice.total = rs("total")
                'invoice.contact = rs("contact")
                invoiceArr.Add(invoice)
            End While
            rs.Close()

        Catch ex As Exception
            MsgBox("Error: " & ex.Message & " " & ex.StackTrace)
        Finally
            If openedconn Then oledbObjConn.Close()
        End Try

        For Each invoice In invoiceArr
            fso.WriteLine("        <invoice>")
            fso.WriteLine("            <InvoiceNum>" & invoice.invoiceNum & "</InvoiceNum>")
            fso.WriteLine("            <OrderNum>" & invoice.orderNum & "</OrderNum>")
            fso.WriteLine("            <Customer>" & invoice.customer & "</Customer>")
            fso.WriteLine("            <InvoiceDate>" & invoice.invoiceDate & "</InvoiceDate>")
            fso.WriteLine("            <CustNum>" & invoice.custNum & "</CustNum>")
            fso.WriteLine("            <total>" & invoice.total & "</total>")
            fso.WriteLine("            <addresscode>" & invoice.addressCode & "</addresscode>")
            fso.WriteLine("            <address>" & invoice.address & "</address>")
            fso.WriteLine("            <city>" & invoice.city & "</city>")
            fso.WriteLine("            <state>" & invoice.state & "</state>")
            fso.WriteLine("            <zip>" & invoice.zip & "</zip>")
            'fso.WriteLine("            <contact>" & invoice.contact & "</contact>")
            fso.WriteLine("            <phone>" & invoice.phone & "</phone>")
            fso.WriteLine("            <repairAmount>" & invoice.repairAmount & "</repairAmount>")
            fso.WriteLine("            <lostAmount>" & invoice.lostAmount & "</lostAmount>")
            fso.WriteLine("            <lines>")
            GetLines(fso, invoice)
            fso.WriteLine("            </lines>")
            fso.WriteLine("        </invoice>")
        Next
    End Sub

    Private Sub GetLines(ByRef fso As StreamWriter, ByVal invoice As InvoiceInfo)
        Dim str As String = "SELECT * FROM tblRentalPERM WHERE (InvoiceNum = '" & invoice.invoiceNum & "')"
        Dim cmd As OleDb.OleDbCommand
        Dim rs As OleDb.OleDbDataReader
        Dim openedconn As Boolean = False

        Try
            If oledbObjConn.State = ConnectionState.Closed Then
                oledbObjConn.Open()
                openedconn = True
            End If
            cmd = New OleDb.OleDbCommand(str, oledbObjConn)
            rs = cmd.ExecuteReader()


            While rs.Read
                fso.WriteLine("                <line>")
                fso.WriteLine("                    <BarCode>" & rs("BarCode") & "</BarCode>")
                fso.WriteLine("                    <timeOut>" & rs("timeOut") & "</timeOut>")
                fso.WriteLine("                    <timeIn>" & rs("timeIn") & "</timeIn>")
                fso.WriteLine("                    <NumDays>" & rs("NumDays") & "</NumDays>")
                fso.WriteLine("                    <amount>" & rs("amount") & "</amount>")
                fso.WriteLine("                    <damaged>" & rs("damaged") & "</damaged>")
                fso.WriteLine("                </line>")
            End While
            rs.Close()

        Catch ex As Exception
            MsgBox("Error: " & ex.Message & " " & ex.StackTrace)
        Finally
            If openedconn Then oledbObjConn.Close()
        End Try
    End Sub

    Private Sub SendXMLtoFTP()
        Dim ftp As FTPClient
        Dim info As FTPInfo = GetFTPInfo()

        Try
            ftp = New FTPClient(info.Host)
            ftp.Login(info.UserName, info.Password)
            ftp.ConnectMode = FTPConnectMode.PASV
            ftp.TransferType = FTPTransferType.ASCII
            ftp.ChDir("/victoryftp/SKRental")
            ftp.Put(xmlFile, "RentalASWnotifier.xml")
            ftp.Quit()
        Catch ex As Exception
            MsgBox("There was an error: " & ex.Message)
        End Try
    End Sub

    Private Function GetFTPInfo() As FTPInfo
        Dim info As New FTPInfo
        Dim openedconn As Boolean
        Try
            If oledbObjConn.State = ConnectionState.Closed Then
                oledbObjConn.Open()
                openedconn = True
            End If
            Dim str As String = "SELECT * FROM tblFTPInfo"
            Dim cmd As New OleDb.OleDbCommand(str, oledbObjConn)
            Dim reader As OleDb.OleDbDataReader = cmd.ExecuteReader()

            If reader.Read() Then
                info.Host = reader("IPAddress")
                info.UserName = reader("UserName")
                info.Password = reader("Password")
            Else
                Throw New Exception("No data found")
            End If
        Catch ex As Exception
            MsgBox("Error retriving FTP info: " & ex.Message & vbCrLf & ex.StackTrace)
        Finally
            If openedconn = True Then oledbObjConn.Close()
        End Try

        Return info
    End Function

Finding File Properties

Tue, 08 May 2012 10:52:22 GMT

Description: Finding the last write time for a file along with pothers

Link: http://www.codekeep.net/snippets/5b5e8633-0ef8-4393-9436-a465ed078422.aspx

 Private Function ImportDate()
        Dim objFileInfo As New FileInfo("C:\Documents and Settings\tbaggett\Desktop\XXDR606057_VP.xls")

        Dim dtLastWriteTime As DateTime = objFileInfo.LastWriteTime

        Return dtLastWriteTime
    End Function

Creating a shortcut with hotkeys

Tue, 24 Apr 2012 14:33:06 GMT

Description: Requires Imports IWshRuntimeLibrary and COM reference Windows Script Host Object

Link: http://www.codekeep.net/snippets/7c9a70ec-ccde-48ae-bc45-7e5cb878ff33.aspx

 Public Sub CreateShortcut()
        Dim shell As WshShell = New WshShellClass 'Create new instance
        Dim shortcut As WshShortcut = shell.CreateShortcut("C:\Documents and Settings\tbaggett\Desktop\RunDatasheet.lnk") 'Path of the Shortcut - Where the Shortcut should be placed
        shortcut.TargetPath = "C:\Program Files\Victory Packaging\Pipeline\RunDatasheet.exe" 'Exe of shortcut
        shortcut.IconLocation = "C:\Program Files\Victory Packaging\Pipeline\RunDatasheet.exe,0" 'It's icon to use
        'shortcut.RelativePath = "C:\Program Files\Victory Packaging\Pipeline"
        shortcut.Hotkey = "Ctrl+Alt+S"
        shortcut.Description = "Launches RunDatasheet" 'It's description
        shortcut.Save() 'Save it.

    End Sub

Opening a ClickOnce from another ClickOnce

Tue, 24 Apr 2012 14:28:36 GMT

Description: Also opening a word doc if the ClickOnce isn't installed

Link: http://www.codekeep.net/snippets/e1531c17-bda5-4ff9-9853-4f776afd5cb6.aspx

 Private Sub cmdMarketByMiles_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdMarketByMiles.Click

        Try
            System.Diagnostics.Process.Start("C:\Documents and Settings\" & strUserName & "\Start Menu\Programs\Victory Packaging Golden State Container\CloseCall.appref-ms")
        Catch ex As Exception
            MsgBox("Please install CloseCall from the web site. You will be redirected there now.")
            Dim doFirstTimeCloseCallInstructionsExist As Boolean
            doFirstTimeCloseCallInstructionsExist = DoesCloseCallInstructionsExist()

            Try
                Shell("C:\Program Files\Microsoft Office\Office11\WINWORD.EXE ""C:\Documents and Settings\" & strUserName & "\Desktop\CLOSECALL FIRST TIME SETUP.docx""", AppWinStyle.NormalFocus)
            Catch exx As Exception
                Shell("C:\Program Files\Microsoft Office\Office12\WINWORD.EXE ""C:\Documents and Settings\" & strUserName & "\Desktop\CLOSECALL FIRST TIME SETUP.docx""", AppWinStyle.NormalFocus)
            End Try

            System.Diagnostics.Process.Start("http://www.victorypackagingsa.com/CloseCall")

        End Try



    End Sub

Running a ClickOnce from another ClickOnce

Mon, 23 Apr 2012 15:36:41 GMT

Description: This is how you can quit having to keep up with 2 programs with the exact code.

Link: http://www.codekeep.net/snippets/fe60a58f-ead9-4176-90a3-78a2d689abe5.aspx

 Private Sub cmdMarketByMiles_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdMarketByMiles.Click

        Try
            System.Diagnostics.Process.Start("C:\Documents and Settings\" & strUserName & "\Start Menu\Programs\Victory Packaging Golden State Container\CloseCall.appref-ms")
        Catch ex As Exception
            MsgBox("Please install CloseCall from the web site.")
            System.Diagnostics.Process.Start("http://www.victorypackagingsa.com/CloseCall")
        End Try
 End Sub

Opening a web page with a button

Mon, 23 Apr 2012 13:43:01 GMT

Description: How to open a web page with just a button click

Link: http://www.codekeep.net/snippets/136813bf-4258-4961-b1b5-a0929abca148.aspx

 	Try
            System.Diagnostics.Process.Start("http://www.victorypackagingsa.com/CloseCall")
        Catch ex As Exception
            MsgBox("There was an error: " & ex.Message & ex.StackTrace)
        End Try

Outlook Task Loading

Mon, 26 Mar 2012 14:36:29 GMT

Description: Open a taks in Outlook from a MTGC combo box

Link: http://www.codekeep.net/snippets/0ca2794f-e842-45b1-ae8d-8da4720fbe28.aspx

Private Sub Mtgc_Tasks_SelectionChangeCommitted(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Mtgc_Tasks.SelectionChangeCommitted
        Dim _contains As Int16 = 0
        Dim leng As Int16 = 0
        Dim objOutlook As Outlook.Application = New Outlook.Application
        Dim objNS As Outlook.NameSpace
        Dim NewContact As Outlook.ContactItem = objOutlook.CreateItem(Outlook.OlItemType.olContactItem)
        Dim cntr As Integer
        Dim isFound As Boolean

        newContact.FullName = txtContactName.Text
        NewContact.CompanyName = txtCompanyName.Text

        objOutlook = New Outlook.Application
        objNS = objOutlook.Session

        Dim objAddressList As Outlook.MAPIFolder

        objAddressList = objNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)

        Dim objItems As Outlook.Items = objAddressList.Items
        Dim objContact As Outlook.ContactItem
        Dim companyName As String = newContact.CompanyName

        For j As Int16 = 1 To objItems.Count
            Try
                objContact = objItems(j)
                If objContact.FullName = newContact.FullName.Trim And objContact.CompanyName.Trim = newContact.CompanyName.Trim Then
                    isFound = True
                    Dim ns As Outlook.NameSpace
                    Dim tasks As Outlook.Items
                    ns = objOutlook.GetNamespace("MAPI")
                    tasks = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderTasks).Items
                    Dim task As Object
                    If tasks.Count > 0 Then
                        taskArr = New List(Of TaskInfo)
                        For Each task In tasks
                            If task.subject = Mtgc_Tasks.SelectedItem.col2 Then
                                'Dim oTsk As Outlook.TaskItem = DirectCast(objOutlook.CreateItem(Outlook.OlItemType.olTaskItem), Outlook.TaskItem)

                                'oTsk.Status = Outlook.OlTaskStatus.olTaskInProgress
                                'oTsk.Subject = task.subject
                                'oTsk.PercentComplete = task.percentComplete
                                'oTsk.StartDate = task.startDate
                                'oTsk.DueDate = task.duedate
                                'oTsk.Importance = task.importance

                                'oTsk.Importance = Outlook.OlImportance.olImportanceHigh

                                task.Display()
                                objOutlook = Nothing
                                task = Nothing
                                Exit For

                            End If
                        Next
                    End If

                    Marshal.ReleaseComObject(objContact)
                    Exit For
                End If
                Marshal.ReleaseComObject(objContact)
                objContact = Nothing
            Catch ex As Exception
                MsgBox("There was an error: " & ex.Message & ex.StackTrace)
            End Try

        Next
    End Sub

DatagridView CellDoubleClick

Thu, 15 Mar 2012 12:35:12 GMT

Description: Double clicking on a dgv

Link: http://www.codekeep.net/snippets/99e5c1bf-ffe2-41a3-bd62-455b94a6ae34.aspx

Private Sub dgv_Contacts_CellDoubleClick(ByVal sender As System.Object, ByVal e As System.Windows.Forms.DataGridViewCellEventArgs) Handles dgv_Contacts.CellDoubleClick

        rowSelected = e.RowIndex

        If rowSelected < 0 Then Exit Sub
        Dim sic As String = dgv_Contacts("primarySic", rowSelected).Value.ToString()
        Dim custNum As String = dgv_Contacts("customerNum", rowSelected).Value.ToString()

    End Sub

Cabecera de XML y Agregado.

Sat, 18 Feb 2012 21:12:18 GMT

Description: Caecera y ejemplo para agergar y crear un documento XML.

Link: http://www.codekeep.net/snippets/60f081c0-200f-4e0f-b55c-071f899485ef.aspx

   'Crea el nuevo documento.
  Dim oDocXML As New XDocument 'nuevo XML doc.

  'Declaración de tipo.
  oDocXML.Declaration = New XDeclaration("1.0", "utf-8", "no")

  'Crea el elemento Main.
  Dim oMainContratos As New XElement("Contratos")

  'Crea el elemento sub con sus atributos.
  Dim oSubContrato As New XElement("Contrato", New XAttribute() {New XAttribute("Numero", cboContrato.Text), New XAttribute("Cuenta1", cboCuenta.Text), New XAttribute("Cuenta2", "N/A"),
                                                         New XAttribute("Nombre", txtNombre.Text), New XAttribute("Domicilio", txtDomicilio.Text),
                                                         New XAttribute("ALadoDe", txtALadoDe.Text), New XAttribute("FrenteA", txtFrenteA.Text), New XAttribute("EntreCalles", txtEntreCalles.Text),
                                                         New XAttribute("Colonia", cboColonia.Text), New XAttribute("CP", txtCP.Text), New XAttribute("Telefono", txtTelefono.Text),
                                                         New XAttribute("Celular", txtCelular.Text), New XAttribute("EMail", txtEmail.Text), New XAttribute("FachadaDomi", txtFachadaDomi.Text),
                                                         New XAttribute("Planta", sPlanta), New XAttribute("Zona", cboZona.Text)})

 'Agrega al sub al main.
  oMainContratos.Add(oSubContrato)

  'Agrega el main al doc.
  oDocXML.Add(oMainContratos)

  'Salva el archivo.
  oDocXML.Save(Application.StartupPath & "\cts\Contrs.bin")

Descargar el C�digo HTML de una pagina web

Sat, 18 Feb 2012 10:45:32 GMT

Description: Descargar el C�digo HTML de una pagina web

Link: http://www.codekeep.net/snippets/6b6b453f-af80-4797-874e-1fe14f678941.aspx

Dim request As System.Net.HttpWebRequest = System.Net.HttpWebRequest.Create("http://www.whatismyip.com/")
  Dim response As System.Net.HttpWebResponse = request.GetResponse()

  Dim sr As System.IO.StreamReader = New System.IO.StreamReader(response.GetResponseStream())

  Dim sourcecode As String = sr.ReadToEnd()
  TextBox1.Text = sourcecode

Outlook Tasks

Tue, 14 Feb 2012 16:10:21 GMT

Description: Adding tasks to outlook

Link: http://www.codekeep.net/snippets/9e080004-e1b9-4f36-a21c-0e511cad442f.aspx

 Private Sub cmdAddTask_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdAddTask.Click
        Dim oApp As Outlook.Application = New Outlook.Application
        Dim cntr As Integer = 0

        If Process.GetProcessesByName("OutLook").Length < 1 Then
            'restarts the Process 
            Process.Start("OutLook.exe")
            Do Until Process.GetProcessesByName("OutLook").Length >= 1
                cntr += 1
            Loop
        End If

        Dim oTsk As Outlook.TaskItem = DirectCast(oApp.CreateItem(Outlook.OlItemType.olTaskItem), Outlook.TaskItem)

        oTsk.Status = Outlook.OlTaskStatus.olTaskInProgress

        'oTsk.PercentComplete = 0

        'oTsk.Importance = Outlook.OlImportance.olImportanceHigh

        oTsk.Subject = "New task for " & txtCompanyName.Text
        oTsk.Display()
        'oTsk.Save()

        ' Clean up.

        oApp = Nothing

        oTsk = Nothing

    End Sub