CodeKeep VB.NET Feed

Finding File Properties

Tue, 08 May 2012 15: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 19: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 19: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 20: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 18: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 19: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 17: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.

Sun, 19 Feb 2012 03: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 16: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 22: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

Outlook Contact Search

Tue, 14 Feb 2012 17:08:22 GMT

Description: Looping through contacts

Link: http://www.codekeep.net/snippets/5174618c-62c3-4630-a39b-a9b10b60cec8.aspx

 Private Sub GetContact(ByVal _name As String)
        Dim first As String = ""
        Dim _contains As Int16 = 0
        Dim last As String = ""
        Dim isFound As Boolean
        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)
        NewContact.FullName = txtContactName.Text
        Dim name As String = NewContact.FullName
        If name Is Nothing Then Exit Sub
        _contains = InStr(name, " ")
        leng = name.Length
        If _contains > 0 Then
            name = name.Substring(0, _contains - 1)
            first = name
            last = NewContact.FullName.Substring(_contains, leng - _contains)
            NewContact.FirstName = first
            NewContact.LastName = last
        End If

        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

        For j As Int16 = 1 To objItems.Count
            Try
                objContact = objItems(j)
                If objContact.FullName = NewContact.FullName And objContact.CompanyName = NewContact.CompanyName Then
                    isFound = True
                    Marshal.ReleaseComObject(objContact)
                    Exit For
                End If
                Marshal.ReleaseComObject(objContact)
                objContact = Nothing
            Catch ex As Exception

            End Try

        Next

        If isFound = True Then
            cmdCreateContact.Image = Image.FromFile("C:\AAAVictoryProgramming\PipelineProject\contact.bmp")
            cmdCreateContact.Text = "Contact"
        Else
            cmdCreateContact.Image = Nothing
            cmdCreateContact.Text = "Create Contact"
        End If

        objContact = Nothing
        objItems = Nothing
        objAddressList = Nothing

    End Sub

Outlook - Add Contact

Thu, 09 Feb 2012 15:59:17 GMT

Description: Adding a contact to Outlook from a form

Link: http://www.codekeep.net/snippets/ac847f43-ab8f-4068-89f1-18d3093f50d9.aspx

Imports Microsoft.Office.Interop


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 outApplication As Outlook.Application = New Outlook.Application()
        Dim xNS As Outlook.NameSpace = outApplication.GetNamespace("mapi")
        xNS.Logon("YourValidProfile", Missing.Value, False, True)
        ' Create an Outlook application.


        ' Get the namespace and the logon.
        Dim outNamSpace As Outlook.NameSpace = outApplication.GetNamespace("MAPI")

        ' Create a new contact item.
        Dim NewContact As Outlook.ContactItem = outApplication.CreateItem(Outlook.OlItemType.olContactItem)

        ' Set some common properties.

        NewContact.FullName = txtContactName.Text

        Dim first As String = ""
        Dim _contains As Int16 = 0
        Dim last As String = ""
        Dim name As String = NewContact.FullName
        Dim leng As Int16 = 0

        _contains = InStr(name, " ")
        leng = name.Length

        If _contains > 0 Then
            name = name.Substring(0, _contains - 1)
            first = name
            last = NewContact.FullName.Substring(_contains, leng - _contains)

            _yes = MsgBox("Is the first name " & first & ", y or n?", MsgBoxStyle.YesNo)
            If _yes = MsgBoxResult.Yes Then
                NewContact.FirstName = first
            End If

            _yes = MsgBox("Is the last name " & last & ", y or n?", MsgBoxStyle.YesNo)
            If _yes = MsgBoxResult.Yes Then
                NewContact.LastName = last
            End If
        End If

        NewContact.CompanyName = txtCompanyName.Text
        Select Case cboStage.Text
            Case "1-Customer/Closed/In Transition"
                'NewContact.Title = "Client"
                NewContact.Categories = "Blue Category"
            Case "2-Proposal Submitted/Waiting Decision"
                NewContact.Categories = "Green Category"
            Case "3-Prospect/Finalizing Proposal"
                NewContact.Categories = "Green Category"
            Case "4-Prospect/Assessing/Developing Deal"
                NewContact.Categories = "Green Category"
            Case "5-Suspect/Potential Prospect"
                NewContact.Categories = "Green Category"
            Case "6-Submitted Proposal/Lost"
                NewContact.Categories = "Red Category"
            Case "7-Pass on Deal / Not a Fit"
                NewContact.Categories = "Red Category"
        End Select

        If txtComments.Text <> "" Then NewContact.Body = txtComments.Text
        'NewContact.Birthday = Convert.ToDateTime("5/4/1969")
        'NewContact.Department = "Development"
        'NewContact.FileAs = "Authorcode"
        'NewContact.Email1Address = "abc@hotmail.com"
        'NewContact.Email2Address = "abc@live.com"
        'NewContact.MailingAddress = "NewDelhi India"
        'NewContact.Subject = "Contact crated from vb.net"
        'NewContact.JobTitle = "Engineer"

        Dim oContacts As Outlook.MAPIFolder = xNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)
        Dim oItems As Outlook.Items = oContacts.Items


        ' Get the first contacts
    
    Outlook automatically looks for duplicate and asks
        'For i As Integer = 1 To oItems.Count
        '    Dim xCont As Outlook.ContactItem
        '    xCont = oItems(i)
        '    If xCont.FullName = NewContact.FullName And xCont.CompanyName = NewContact.CompanyName Then
        '        MsgBox("That contact has already been created.")
        '        xCont.Display()
        '        Exit Sub
        '    End If
        'Next

        NewContact.Display()
        'NewContact.Save()

        outApplication = Nothing
        outNamSpace = Nothing
        NewContact = Nothing

Threading a Sql update

Mon, 30 Jan 2012 19:13:18 GMT

Description: This one is simpler than most

Link: http://www.codekeep.net/snippets/63211be1-6ed8-49b1-b725-c56eeb72a764.aspx

Imports System.Threading
'threadSub
Dim op As New ParameterizedThreadStart(AddressOf CreateSQLCompany)
            Dim newThread As New Thread(op)
            newThread.Start(sqlCompany)
'end thread sub

Private Sub CreateSQLCompany(ByVal comp As Object)
        Try
            CompanyInfoData.Instance.CreateSql(comp)
        Catch ex As Exception
            MsgBox("There was an error: " & ex.Message & ex.StackTrace)
        End Try
End Sub
 
Private Delegate Sub UIdelegate()

File creation and deletion

Thu, 26 Jan 2012 21:32:31 GMT

Description: Finding a file deleting and re-adding it

Link: http://www.codekeep.net/snippets/8c162f0a-80e4-482d-92ba-11a5aab34bf8.aspx

 Public Sub CreateRunDatasheet()
        Dim fileSource As String = "\\srvfile1\PipelineUsers\Databases\Pipeline\"
        Dim fileDestination As String = "C:\Program Files\Victory Packaging\Pipeline"
        Dim fileName As String = "RunDatasheet.exe"
        Dim fMsg As New WaitingForm
        Dim deleteFile As String = "C:\Program Files\Victory Packaging\Pipeline\RunDatasheet.exe"
        'create a new object for the message form
        fMsg.TopMost = True                'this is to make sure that the message form is displayed at the top of your windows and the users cannot do anything to it except waiting
        fMsg.Show()

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

        My.Computer.FileSystem.CopyFile(fileSource & "\" & fileName, fileDestination & "\" & fileName)

        fMsg.Close()
    End Sub

Desktop shortcut and hotkeys

Thu, 26 Jan 2012 21:25:30 GMT

Description: Creating a shortcut programatically

Link: http://www.codekeep.net/snippets/5c91bd84-a5a9-4bf5-8bc7-b1e6a7d5a366.aspx

'you must add the reference Com Windows Script Host Object Model
Imports IWshRuntimeLibrary

Private 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.Hotkey = "Ctrl+Alt+S"
        shortcut.Description = "Launches RunDatasheet" 'It's description
        shortcut.Save() 'Save it.
    End Sub

GetGroupsCounts

Tue, 24 Jan 2012 07:49:10 GMT

Description: Get a list of occurrence counts of all items in a List.

Link: http://www.codekeep.net/snippets/d409e77a-a864-4b28-ad06-a5f8290bfcf6.aspx

    Private Function GetGroups(fullList As List(Of String)) As List(Of Tuple(Of String, Integer))
        Dim groups As New List(Of Tuple(Of String, Integer))

        Dim result = From i In fullList
                     Group i By i Into Group
                     Order By Group.Count() Descending
                     Select i, Count = Group.Count()

        For Each item In result
            Dim group As New Tuple(Of String, Integer)(item.i, item.Count)
            groups.Add(group)
        Next

        Return groups
    End Function

Get Count of Item Occurrences in a List of String

Tue, 24 Jan 2012 07:46:42 GMT

Description: Two ways to the the count of a specified string in a list of strings.

Link: http://www.codekeep.net/snippets/b0fd0c18-68ce-43a9-a95f-2bd690e92a47.aspx

    Private Function GetOccurrencesCount(valueToFind As String, fullList As List(Of String)) As Integer
        Dim count As Integer = (From temp In fullList
                                Where temp.Equals(valueToFind)
                                Select temp).Count

        Return count
    End Function

    Private Function GetOccurrencesCount2(valueToFind As String, fullList As List(Of String)) As Integer
        Dim count As Integer = fullList.Where(Function(temp) temp.Equals(valueToFind)).Select(Function(temp) temp).Count

        Return count
    End Function

Update a progress bar in a loop in WPF

Fri, 13 Jan 2012 10:01:34 GMT

Description: Progress bars don't update in WPF when they're incremented from within a loop and there's no DoEvents to use. This will sort it out.

Link: http://www.codekeep.net/snippets/9df57f1f-be01-446b-88cf-927874369ed0.aspx

    Private Sub IncremenetProgressBarDelegate()
        ProgressBar1.Value += 1
    End Sub

    Private Sub IncrementProgressBar()
        Application.Current.Dispatcher.Invoke(DispatcherPriority.Background, New Action(AddressOf IncremenetProgressBarDelegate))
    End Sub

Checking to see if a program is running

Wed, 11 Jan 2012 20:21:55 GMT

Description: If the program isn't running then it will open.

Link: http://www.codekeep.net/snippets/bb6915e7-a8e3-4a90-9699-e40f406acec7.aspx

 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

Outlook Appointment Automation

Wed, 11 Jan 2012 19:02:07 GMT

Description: Add an appointment to Outlook.

Link: http://www.codekeep.net/snippets/713cf921-6647-4890-9c63-b4486317a03e.aspx

    Private Sub cmdCreateAppt_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdCreateAppt.Click
        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 oApp As Outlook.Application = New Outlook.Application()

        ' Get NameSpace and Logon.
        Dim oNS As Outlook.NameSpace = oApp.GetNamespace("mapi")
        oNS.Logon(r.UserName, Missing.Value, False, True)

        ' Create a new AppointmentItem.
        Dim oAppt As Outlook.AppointmentItem = oApp.CreateItem(Outlook.OlItemType.olAppointmentItem)
        'oAppt.Display(true)  'Modal    

        ' Set some common properties.
        If txtCompanyName.Text = "" Then
            oAppt.Location = InputBox("Enter in the company name or appointment place.")
        Else
            oAppt.Location = txtCompanyName.Text
        End If

        oAppt.Subject = InputBox("Enter in the subject of the appt.")
        oAppt.Body = InputBox("Enter in the body message.")

        Dim _date As Date = OutlookDatePicker.Text

        Dim _time As Date = OutlookTimePicker.Text

        oAppt.Start = Convert.ToDateTime(_date & " " & _time)

        oAppt.Duration = InputBox("Enter in the appt. duration you expect.")
        oAppt.End = oAppt.Start.AddMinutes(oAppt.Duration)
        oAppt.ReminderSet = True
        oAppt.ReminderMinutesBeforeStart = 15
        oAppt.BusyStatus = Outlook.OlBusyStatus.olBusy
        oAppt.IsOnlineMeeting = False

        ' Save to Calendar.
        oAppt.Save()

        ' Display.
        oAppt.Display(True)

        ' Logoff.
        oNS.Logoff()

        ' Clean up.
        oApp = Nothing
        oNS = Nothing
        oAppt = Nothing
    End Sub

ComboBox validation

Tue, 10 Jan 2012 14:45:59 GMT

Description: Making sure the text entered in a combo box is one of the selections

Link: http://www.codekeep.net/snippets/ab9d9502-2025-4e32-abfb-3d4dba633532.aspx

Private Sub cboStage_Leave(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cboStage.Leave
        Dim dRow As DataRow
        Dim dCol As DataColumn
        Dim dt As New DataTable
        Dim isFound As Boolean
        Dim str As String = ""

        If cboStage.Text <> "" Then
            dt = stages.BuildStages
            For i As Int16 = 0 To dt.Rows.Count - 1
                dRow = dt.Rows(i)
                If dRow("stage") = cboStage.Text Then
                    isFound = True
                    Exit For
                End If
            Next
            If isFound = False Then
                MsgBox("You must make a selection from the list.")
                cboStage.Text = ""
                Exit Sub
            End If
        End If
    End Sub

NumberToWords

Thu, 05 Jan 2012 05:56:46 GMT

Description: NumberToWords

Link: http://www.codekeep.net/snippets/f6ec6753-8ba3-41a3-b113-ee8f5cc97553.aspx

Public Class NumberToWords
    'Public Class clsConversion

    Dim mOnesArray(8) As String
    Dim mOneTensArray(9) As String
    Dim mTensArray(7) As String
    Dim mPlaceValues(4) As String


    Public Sub New()

        mOnesArray(0) = "One"
        mOnesArray(1) = "Two"
        mOnesArray(2) = "Three"
        mOnesArray(3) = "Four"
        mOnesArray(4) = "Five"
        mOnesArray(5) = "Six"
        mOnesArray(6) = "Seven"
        mOnesArray(7) = "Eight"
        mOnesArray(8) = "Nine"

        mOneTensArray(0) = "Ten"
        mOneTensArray(1) = "Eleven"
        mOneTensArray(2) = "Twelve"
        mOneTensArray(3) = "Thirteen"
        mOneTensArray(4) = "Fourteen"
        mOneTensArray(5) = "Fifteen"
        mOneTensArray(6) = "Sixteen"
        mOneTensArray(7) = "Seventeen"
        mOneTensArray(8) = "Eighteen"
        mOneTensArray(9) = "Nineteen"

        mTensArray(0) = "Twenty"
        mTensArray(1) = "Thirty"
        mTensArray(2) = "Forty"
        mTensArray(3) = "Fifty"
        mTensArray(4) = "Sixty"
        mTensArray(5) = "Seventy"
        mTensArray(6) = "Eighty"
        mTensArray(7) = "Ninety"

        mPlaceValues(0) = "Hundred"
        mPlaceValues(1) = "Thousand"
        mPlaceValues(2) = "Million"
        mPlaceValues(3) = "Billion"
        mPlaceValues(4) = "Trillion"

    End Sub


    Protected Function GetOnes(ByVal OneDigit As Integer) As String

        GetOnes = ""

        If OneDigit = 0 Then
            Exit Function
        End If

        GetOnes = mOnesArray(OneDigit - 1)

    End Function


    Protected Function GetTens(ByVal TensDigit As Integer) As String

        GetTens = ""

        If TensDigit = 0 Or TensDigit = 1 Then
            Exit Function
        End If

        GetTens = mTensArray(TensDigit - 2)

    End Function


    Public Function ConvertNumberToWords(ByVal NumberValue As String) As String

        Dim Delimiter As String = " "
        Dim TensDelimiter As String = "-"
        Dim mNumberValue As String = ""
        Dim mNumbers As String = ""
        Dim mNumWord As String = ""
        Dim mFraction As String = ""
        Dim mNumberStack() As String
        Dim j As Integer = 0
        Dim i As Integer = 0
        Dim mOneTens As Boolean = False

        ConvertNumberToWords = ""

        ' validate input
        Try
            j = CDbl(NumberValue)
        Catch ex As Exception
            ConvertNumberToWords = "Invalid input."
            Exit Function
        End Try

        ' get fractional part {if any}
        If InStr(NumberValue, ".") = 0 Then
            ' no fraction
            mNumberValue = NumberValue
        Else
            mNumberValue = Microsoft.VisualBasic.Left(NumberValue, InStr(NumberValue, ".") - 1)
            mFraction = Mid(NumberValue, InStr(NumberValue, ".")) ' + 1)
            mFraction = Math.Round(CSng(mFraction), 2) * 100

            If CInt(mFraction) = 0 Then
                mFraction = ""
            Else
                mFraction = "&& " & mFraction & "/100"
            End If
        End If
        mNumbers = mNumberValue.ToCharArray

        ' move numbers to stack/array backwards
        For j = mNumbers.Length - 1 To 0 Step -1
            ReDim Preserve mNumberStack(i)

            mNumberStack(i) = mNumbers(j)
            i += 1
        Next

        For j = mNumbers.Length - 1 To 0 Step -1
            Select Case j
                Case 0, 3, 6, 9, 12
                    ' ones  value
                    If Not mOneTens Then
                        mNumWord &= GetOnes(Val(mNumberStack(j))) & Delimiter
                    End If

                    Select Case j
                        Case 3
                            ' thousands
                            mNumWord &= mPlaceValues(1) & Delimiter

                        Case 6
                            ' millions
                            mNumWord &= mPlaceValues(2) & Delimiter

                        Case 9
                            ' billions
                            mNumWord &= mPlaceValues(3) & Delimiter

                        Case 12
                            ' trillions
                            mNumWord &= mPlaceValues(4) & Delimiter
                    End Select


                Case Is = 1, 4, 7, 10, 13
                    ' tens value
                    If Val(mNumberStack(j)) = 0 Then
                        mNumWord &= GetOnes(Val(mNumberStack(j - 1))) & Delimiter
                        mOneTens = True
                        Exit Select
                    End If

                    If Val(mNumberStack(j)) = 1 Then
                        mNumWord &= mOneTensArray(Val(mNumberStack(j - 1))) & Delimiter
                        mOneTens = True
                        Exit Select
                    End If

                    mNumWord &= GetTens(Val(mNumberStack(j)))

                    ' this places the tensdelimiter; check for succeeding 0
                    If Val(mNumberStack(j - 1)) <> 0 Then
                        mNumWord &= TensDelimiter
                    End If
                    mOneTens = False

                Case Else
                    ' hundreds value 
                    mNumWord &= GetOnes(Val(mNumberStack(j))) & Delimiter

                    If Val(mNumberStack(j)) <> 0 Then
                        mNumWord &= mPlaceValues(0) & Delimiter
                    End If
            End Select
        Next

        Return mNumWord & mFraction

    End Function



End Class

'End Class

Write text over image code

Wed, 04 Jan 2012 11:00:57 GMT

Description: Just the basics of a class for writing text over an image. About 90% complete.

Link: http://www.codekeep.net/snippets/b8daaf77-eec6-42d6-a1c5-0983765a8ed0.aspx

Imports System.Drawing
Imports System.Drawing.Drawing2D
Imports System.Drawing.Text
Imports System.IO

Public Class ImageTextWriter

    Public Enum TextColour
        Black
        White
    End Enum

    Public Enum vAlignment
        Top
        Middle
        Bottom
    End Enum

    Public Enum hAlignment
        Left
        Center
        Right
    End Enum

    Public Sub New()

    End Sub

    Public Shared Function OverlayText(ByVal ImageData() As Byte, ByVal Text As String, ByVal FontSize As Integer, ByVal Colour As TextColour, ByVal HorizontalAlignment As hAlignment, ByVal VerticalAlignment As vAlignment) As Byte()

        Dim sf As New StringFormat
        Dim padding As Integer = 5 'Drawing rectangle will be reduced by this much

        Select Case HorizontalAlignment
            Case hAlignment.Left
                sf.Alignment = StringAlignment.Near
            Case hAlignment.Right
                sf.Alignment = StringAlignment.Far
            Case hAlignment.Center
                sf.Alignment = StringAlignment.Center
        End Select

        Select Case VerticalAlignment
            Case vAlignment.Top
                sf.LineAlignment = StringAlignment.Near
            Case vAlignment.Middle
                sf.LineAlignment = StringAlignment.Center
            Case vAlignment.Bottom
                sf.LineAlignment = StringAlignment.Far
        End Select

        'Prepare a brush for the colour
        Dim b As SolidBrush

        Select Case Colour
            Case TextColour.Black
                b = New SolidBrush(Color.Black)
            Case TextColour.White
                b = New SolidBrush(Color.White)
        End Select

        Dim NewImage As Bitmap = New Bitmap(ConvertByteArrayToBitmap(ImageData))

        'Measure the size of the image for alignment of text
        Dim r As New Rectangle(New Point(padding, padding), NewImage.Size)

        r.Height = r.Height - padding
        r.Width = r.Width - padding

        'Prepare the graphics object
        Dim g As Graphics = Graphics.FromImage(NewImage)
        g.SmoothingMode = SmoothingMode.AntiAlias

        'Declare the font
        Dim f As New Font("Arial", FontSize, FontStyle.Regular)

        'Draw the text
        g.DrawString(Text, f, b, r, sf)

        Dim ms As New MemoryStream
        NewImage.Save(ms, System.Drawing.Imaging.ImageFormat.Png)
        Dim output() As Byte
        output = ms.ToArray
        Return output

    End Function

    Public Shared Function ConvertByteArrayToBitmap(ByVal Input() As Byte) As Bitmap
        Dim ms As New MemoryStream
        ms.Write(Input, 0, Input.Length)
        Dim InputImage As New Bitmap(ms)
        Return InputImage
    End Function

    Public Shared Function ConvertBitmapToByteArray(ByVal Input As Bitmap) As Byte()
        Dim ms As New MemoryStream
        Input.Save(ms, System.Drawing.Imaging.ImageFormat.Bmp)
        Dim output() As Byte
        output = ms.ToArray
        Return output
    End Function

End Class

Screen Resolution/ Change Form Size

Thu, 29 Dec 2011 17:07:04 GMT

Description: Determine the screen resolution and change the form size

Link: http://www.codekeep.net/snippets/68582636-4b76-47a6-9396-36c977ad9ec7.aspx

 Dim ScreenWidth As String = System.Windows.Forms.Screen.PrimaryScreen.Bounds.Width.ToString()
        Dim ScreenHeight As String = System.Windows.Forms.Screen.PrimaryScreen.Bounds.Height.ToString()

        If ScreenHeight < 800 Then
            'Me.Size = New System.Drawing.Size(1200, 900) '1667, 1196
            If r.IsManager = True And r.SalesRegion <> "FP" Then
                MessageBox.Show("Your ScreenWidth is: " + ScreenWidth + " x " + ScreenHeight & ". This size screen will not accomodate the charts. You must change your screen resolution manually to see the charts properly.")
                'pnl_Manager.Size = New System.Drawing.Size(1190, 700) '1642, 966
                'StagePercViewer.Size = New System.Drawing.Size(500, 250) '889, 450
                'PipelinePercViewer.Size = New System.Drawing.Size(300, 150) '505, 450
                'LostPercViewer.Size = New System.Drawing.Size(1190, 700) '793, 465
                'WonPercViewer.Size = New System.Drawing.Size(1190, 700) '833, 465
            End If
        End If

IsNumeric in WHERE statement for MS Access

Fri, 23 Dec 2011 18:04:53 GMT

Description: Using IsNumeric as the WHERE statment to return only numbers

Link: http://www.codekeep.net/snippets/5f1ede43-58c6-4bec-a749-3b5dd1b7e366.aspx

 Public Function FindAllOriginals() As InvoiceCustomerCollection
        Dim tbl As New DataTable

        Using conn As New OleDbConnection(getMoverStr())
            conn.Open()
            Dim cmd As OleDbCommand = conn.CreateCommand

            cmd.CommandText = "SELECT Invoice.notes, Invoice.exported, Invoice.invoiceNum, Invoice.registrationNum, Invoice.invoiceDate, " _
            & " Shipment.firstName, Shipment.lastName FROM Customer INNER JOIN (Invoice INNER JOIN Shipment ON Invoice.registrationNum = Shipment.registrationNum) " _
            & " ON Customer.customerID = Shipment.customerID WHERE (IsNumeric([Invoice.invoiceNum]))"

            Dim reader As OleDb.OleDbDataReader = cmd.ExecuteReader
            tbl.Load(reader)
        End Using

        Return MapDataToInvoiceCustomer(tbl)

    End Function