' Form and code by Jonathan Geier
'---------------------------------------------------------------------------------------------------
' This form creates an email containing a worklog for an incident, and emails it directly to BOX TSC.
' A different subject line will be generated based on whether you click "Resolve" or "Escalate" after filling out the form.
' BOX TSC will then sort the incoming email based on the subject line.
'
' You may create a button in the ribbon of Outlook, triggering a macro with the following code, to quickly access this tool after importing it:
' CODE:  Worklog.Show vbModeless
'---------------------------------------------------------------------------------------------------
' TO DO:
' - use regex to validate fields
'---------------------------------------------------------------------------------------------------

Dim blnValidationError As Boolean
Dim dblTotalMB As Double

Private Sub UserForm_Initialize()
' Set up the form for use
'---------------------------------------------------------------------------------------------------
  btnFillOut.Visible = False
  lblTSRNameAndID.Caption = GetTSRName & " (" & UCase(Environ("USERNAME")) & ")"

  With cboNewRecurring
    .AddItem "- Select -", 0
    .AddItem "New", 1
    .AddItem "Recurring", 2
  End With
  cboNewRecurring.ListIndex = 0
  
  With cboStatus
    .AddItem "- Select -", 0
    .AddItem "Assigned", 1
    .AddItem "Pending", 2
    .AddItem "In Progress", 3
    .AddItem "Assumed Resolved", 4
    .AddItem "Confirmed Resolved", 5
  End With
  cboStatus.ListIndex = 0
  
  With cboComputerModel
    .AddItem "- Select -", 0
    .AddItem "Dell Latitude D620", 1
    .AddItem "Dell Latitude D630", 2
    .AddItem "Dell Optiplex 745", 3
    .AddItem "Lenovo ThinkPad T42", 4
    .AddItem "Lenovo ThinkPad T61", 5
    .AddItem "Lenovo ThinkPad T500", 6
    .AddItem "Lenovo ThinkPad T420", 7
    .AddItem "Lenovo ThinkPad T420S", 8
    .AddItem "Lenovo ThinkPad X220", 9
    .AddItem "Lenovo ThinkCenter M81", 10
  End With
  cboComputerModel.ListIndex = 0
  
  With cboOS
    .AddItem "- Select -", 0
    .AddItem "Microsoft Windows XP Professional", 1
    .AddItem "Microsoft Windows 7 Professional", 2
  End With
  cboOS.ListIndex = 0
  
  With lstAttachments
    .ColumnHeads = False
    .ColumnCount = 4
    .ColumnWidths = "250;280;85;50" '668.25
    .BoundColumn = 1
  End With
  
  dblTotalMB = 0
  lblTotalMB.Caption = Round(dblTotalMB, 2) & "MB"
End Sub

Private Function GetTSRName() As String
' Gets the user's name from Outlook
'---------------------------------------------------------------------------------------------------
  Dim myOlApp, myNameSpace As Object
  
  Set myOlApp = CreateObject("Outlook.Application")
  Set myNameSpace = myOlApp.GetNamespace("MAPI")
  
  GetTSRName = myNameSpace.CurrentUser.Name
End Function

Private Sub txtAssetTag_Exit(ByVal Cancel As MSForms.ReturnBoolean)
' For when the user tabs off of the "Asset Tag" field, converts string to upper-case
'---------------------------------------------------------------------------------------------------
  txtAssetTag.Text = UCase(txtAssetTag.Text)
End Sub

Private Sub txtReleaseVersion_Exit(ByVal Cancel As MSForms.ReturnBoolean)
' For when the user tabs off of the "Release Version" field, converts string to upper-case
'---------------------------------------------------------------------------------------------------
  txtReleaseVersion.Text = UCase(txtReleaseVersion.Text)
End Sub

Private Sub txtUserTSID_Exit(ByVal Cancel As MSForms.ReturnBoolean)
' For when the user tabs off of the "User TSID" field, converts string to upper-case
'---------------------------------------------------------------------------------------------------
  txtUserTSID.Text = UCase(txtUserTSID.Text)
End Sub

Private Sub cboComputerModel_Change()
' For when the user changed the model of the computer; chooses the operating system
'---------------------------------------------------------------------------------------------------
  Select Case cboComputerModel.ListIndex
    Case 1, 2, 3, 4, 5
      cboOS.ListIndex = 1
    Case 6, 7, 8, 9, 10
      cboOS.ListIndex = 2
    Case Else
      '....
  End Select
End Sub

Private Sub ValidateFields()
' validates that all necessary fields are filled out, and that the data is well-formed; sets a
' global variable, "blnValidationError" to "true" if it encounters an issue.
'---------------------------------------------------------------------------------------------------
  blnValidationError = False

  If Not Left(txtUserTSID.Text, 2) = "TS" Or Not IsNumeric(Right(txtUserTSID.Text, 5)) Then
    MsgBox "Please enter a valid TSID for the user.", vbOKOnly + vbCritical + vbApplicationModal, "Error."
    txtUserTSID.SetFocus
    blnValidationError = True
    Exit Sub
  End If
  
  If Len(txtUserName.Text) = 0 Then 'also check for at least one space...
    MsgBox "Please enter the user's name.", vbOKOnly + vbCritical + vbApplicationModal, "Error."
    txtUserName.SetFocus
    blnValidationError = True
    Exit Sub
  End If

  If Len(txtAssetTag.Text) <> 8 And txtAssetTag.Text <> "REMOTE" Then
    MsgBox "Please Enter a valid asset tag for the user's machine." & vbNewLine & "Enter ""REMOTE"" if the user is Remote Access.", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    txtAssetTag.SetFocus
    blnValidationError = True
    
    Exit Sub
  End If
  
  If Len(txtReleaseVersion.Text) <> 0 Then
    If Len(txtReleaseVersion.Text) <> 5 Or Not IsNumeric(Left(txtReleaseVersion.Text, 4)) Then
      MsgBox "Entering the release version is optinal, but please use this format: 20##X.", vbOKOnly + vbCritical + vbApplicationModal, "Error"
      txtReleaseVersion.SetFocus
      blnValidationError = True
      Exit Sub
    End If
  End If
  
  If Len(txtIssueProblem.Text) = 0 Then
    MsgBox "Please enter a detailed description of the issue.", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    txtIssueProblem.SetFocus
    blnValidationError = True
    Exit Sub
  End If
  
  If Len(txtApplication.Text) = 0 Then
    MsgBox "Please enter the name of the application in question.", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    txtApplication.SetFocus
    blnValidationError = True
    Exit Sub
  End If
  
  If cboNewRecurring.ListIndex = 0 Then
    MsgBox "Please select ""New"" or ""Recurring"".", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    cboNewRecurring.SetFocus
    blnValidationError = True
    Exit Sub
  End If
  
  If Len(txtErrorMessage.Text) = 0 Then
    MsgBox "Please enter an error message." & vbNewLine & "If there is no error message, enter ""N/A"".", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    txtErrorMessage.SetFocus
    blnValidationError = True
    Exit Sub
  End If
  
  If Len(txtTSRStepsTaken.Text) = 0 Then
    MsgBox "Please enter the steps taken on the issue thus far.", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    txtErrorMessage.SetFocus
    blnValidationError = True
    Exit Sub
  End If
  
  If cboStatus.ListIndex = 0 Then
    MsgBox "Please select a status for the incident.", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    cboStatus.SetFocus
    blnValidationError = True
    Exit Sub
  End If
  
  If Len(txtNextSteps.Text) = 0 Then
    MsgBox "Please enter the steps to be taken next.", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    txtNextSteps.SetFocus
    blnValidationError = True
    Exit Sub
  End If
End Sub

Private Sub DeleteSignatureBlock(Email As Outlook.MailItem)
' Deletes signature block from email
'----------------------------------------------------------
  Dim objDoc As Word.Document
  Dim objBookmark As Word.Bookmark
  
  On Error Resume Next
  Set objDoc = Email.GetInspector.WordEditor
  Set objBookmark = objDoc.Bookmarks("_MailAutoSig")
  If Not objBookmark Is Nothing Then
    objBookmark.Select
    objDoc.Windows(1).Selection.Delete
  End If
  Set objDoc = Nothing
  Set objBookmark = Nothing
End Sub

Private Sub ComposeEmailAndSend(strMode As String)
' Composes an Outlook email from the information in the form and sends it
'---------------------------------------------------------------------------------------------------
  Dim strColor As String
  Dim strTo As String
  Dim objOL As Outlook.Application
  Dim objEmail As Outlook.MailItem

  Set objOL = CreateObject("Outlook.Application")
  Set objEmail = objOL.CreateItem(olMailItem)
  
  objEmail.Display
  Call DeleteSignatureBlock(objEmail)

  If strMode = "RESOLVE" Then
    strColor = "rgb(0,255,0)"
    strTo = "boxtsc@thrivent.com"
  ElseIf strMode = "ESCALATE" Then
    strColor = "rgb(255,0,0)"
    strTo = "boxsrt2@thrivent.com"
  End If
  
  objEmail.To = strTo
  SendKeys "%k", True
  
  objEmail.Subject = "TSC Outlook Worklog: " & UCase(strMode) & "D"

  objEmail.HTMLBody = "
"
    objEmail.HTMLBody = objEmail.HTMLBody & "
" & UCase(strMode) & "D
"
    objEmail.HTMLBody = objEmail.HTMLBody & "
Worklog generated by " & GetTSRName & " (" & UCase(Environ("USERNAME")) & ") on " & WeekdayName(Weekday(Date)) & ", " & MonthName(Month(Date)) & " " & Day(Now) & ", " & Year(Now) & ", at " & Time() & "
"
    objEmail.HTMLBody = objEmail.HTMLBody & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Called in by: " & txtUserName.Text & " (" & UCase(txtUserTSID.Text) & ")
"
      '  "
Phone: 123/456-7890
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Asset Tag: " & UCase(txtAssetTag.Text) & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Computer Model: " & cboComputerModel.Text & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Release Version: " & UCase(txtReleaseVersion) & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Operating System: " & cboOS.Text & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
========================================================
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Application: " & txtApplication.Text & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
New/Recurring: " & cboNewRecurring.Text & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Issue/Problem:
 " & Replace(txtIssueProblem.Text, vbLf, "
") & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Error Message:
 " & Replace(txtErrorMessage.Text, vbLf, "
") & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
TSR Steps Taken:
 " & Replace(txtTSRStepsTaken.Text, vbLf, "
") & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Status: " & cboStatus.Text & "
"
      objEmail.HTMLBody = objEmail.HTMLBody & "
Next Steps:
 " & Replace(txtNextSteps.Text, vbLf, "
") & "
"
    objEmail.HTMLBody = objEmail.HTMLBody & "
"
    objEmail.HTMLBody = objEmail.HTMLBody & "
Screenshots/Images:
"
      If lstAttachments.ListCount = 0 Then
        objEmail.HTMLBody = objEmail.HTMLBody & "
None.
"
      Else
        For Row = 0 To lstAttachments.ListCount - 1
          If lstAttachments.Column(2, Row) = "Image" Then
            objEmail.HTMLBody = objEmail.HTMLBody & "
"
          End If
          objEmail.Attachments.Add (lstAttachments.Column(1, Row) & "\" & lstAttachments.Column(0, Row))
        Next Row
      End If
    objEmail.HTMLBody = objEmail.HTMLBody & "
"
  objEmail.HTMLBody = objEmail.HTMLBody & "
"
  If chkPreviewEmail.Value Then GoTo Reset
  objEmail.Send
Reset:
  Call btnClear_Click
End Sub

Private Sub btnAddImage_Click()
' Opens a file picker dialog, and adds a list item to the listbox
'---------------------------------------------------------------------------------------------------
  Const msoFileDialogOpen = 1
  
  Dim objWord As Word.Application
  Dim fdFile As Office.FileDialog
  Dim Var As Variant
  Dim strFilePath As String
  Dim strFileName As String
  Dim lngFileSize As String
  Dim strFileType As String

  Set objWord = New Word.Application
  Set fdFile = objWord.FileDialog(msoFileDialogFilePicker)
  
  objWord.Visible = False
  objWord.ChangeFileOpenDirectory (Environ("USERPROFILE") & "\Desktop\")
  
  With fdFile
    .Title = "Select An Image To Add"
    .AllowMultiSelect = True
    With .Filters
      .Clear
      .Add "Images", "*.jpg; *.jpeg; *.gif; *.png, *.bmp"
      .Add "Adobe PDF Files", "*.pdf"
      .Add "Text Files", "*.txt"
      .Add "HTML Files, Web pages", "*.htm; *.html"
      .Add "MS Excel Files", "*.xls; *.xlsx; *.csv"
      .Add "MS Word Files", "*.doc; *.docx"
      .Add "MS Outlook Email Files", "*.msg"
    End With
  End With
  
  If fdFile.Show = -1 Then
    objWord.WindowState = 2
  End If
  
  If fdFile.SelectedItems.Count = 0 Then
    GoTo CloseUp
  Else
    Dim i As Integer
    For i = 1 To fdFile.SelectedItems.Count
    strFilePath = fdFile.InitialFileName
    strFileName = fdFile.SelectedItems.item(i)
    lngFileSize = FileLen(strFileName)
    If LCase(Right(strFileName, 4)) = ".jpg" Or LCase(Right(strFileName, 5)) = ".jpeg" Or LCase(Right(strFileName, 4)) = ".gif" Or LCase(Right(strFileName, 4)) = ".png" Or LCase(Right(strFileName, 4)) = ".bmp" Then
      strFileType = "Image"
    ElseIf LCase(Right(strFileName, 4)) = ".pdf" Then
      strFileType = "PDF"
    ElseIf LCase(Right(strFileName, 4)) = ".txt" Then
      strFileType = "Text File"
    ElseIf LCase(Right(strFileName, 4)) = ".htm" Or LCase(Right(strFileName, 5)) = ".html" Then
    strFileType = "HTML File"
    ElseIf LCase(Right(strFileName, 4)) = ".xls" Or LCase(Right(strFileName, 4)) = ".csv" Or LCase(Right(strFileName, 5)) = ".xlsx" Then
      strFileType = "Excel File"
    ElseIf LCase(Right(strFileName, 4)) = ".doc" Or LCase(Right(strFileName, 5)) = ".docx" Then
      strFileType = "Word File"
    ElseIf LCase(Right(strFileName, 4)) = ".msg" Then
      strFileType = "Outlook Email"
      End If
    strFileName = Replace(strFileName, strFilePath, "")
    lngFileSize = lngFileSize / 1048576
    lngFileSize = Round(lngFileSize, 2)
  
    If dblTotalMB + lngFileSize >= 30 Then
      MsgBox "Attaching the document """ & strFileName & """ to your worklog will cause the resulting email to be unsendable, due to the attachment restriction of 30MB." & vbNewLine & "Current total file size: " & dblTotalMB & "MB" & vbNewLine & "File you are trying to attach: " & lngFileSize & "MB", vbOKOnly + vbInformation, "Maximum file size exceeded."
    Else
      With lstAttachments
        .AddItem
        .Column(0, lstAttachments.ListCount - 1) = strFileName
        .Column(1, lstAttachments.ListCount - 1) = strFilePath
        .Column(2, lstAttachments.ListCount - 1) = strFileType
        .Column(3, lstAttachments.ListCount - 1) = lngFileSize & "MB"
      End With

      dblTotalMB = Round(dblTotalMB + lngFileSize, 2)
      lblTotalMB.Caption = dblTotalMB & "MB"
    End If
    Next i
  End If
  
CloseUp:
  objWord.Quit
  Set objWord = Nothing
End Sub

Private Sub btnRemoveImage_Click()
  Dim Size As String
  
  Size = lstAttachments.Column(3, lstAttachments.ListIndex)
  Size = Replace(Size, "MB", "")
  Size = Val(Size)
  If lstAttachments.Value = lstAttachments Then
    lstAttachments.RemoveItem (lstAttachments.ListIndex)
    dblTotalMB = dblTotalMB - Size
    lblTotalMB.Caption = Round(dblTotalMB, 2) & "MB"
  Else
    MsgBox "Please select an image to be removed from this list.", vbOKOnly + vbCritical, "Error"
  End If
End Sub

Private Sub btnResolve_Click()
' "Resolves" the worklog - sends it to BOX TSC
'---------------------------------------------------------------------------------------------------
  Call ValidateFields
  
  If cboStatus.ListIndex < 4 And cboStatus.ListIndex <> 0 Then
    MsgBox "You are trying to RESOLVE this worklog." & vbNewLine & _
    "To RESOLVE it, you must choose one of the following statuses:" & vbNewLine & _
    "- ""Assumed Resolved""" & vbNewLine & _
    "- ""Confirmed Resolved""", vbOKOnly + vbCritical + vbApplicationModal, "Error"
    cboStatus.SetFocus
    blnValidationError = True
  End If
  
  If blnValidationError = False Then
    Call ComposeEmailAndSend("RESOLVE")
  End If
End Sub

Private Sub btnEscalate_Click()
' "Resolves" the worklog - sends it to BOX SRT
'---------------------------------------------------------------------------------------------------
  Call ValidateFields
  
  If cboStatus.ListIndex > 3 Then
    MsgBox "You are trying to ESCALATE this worklog." & vbNewLine & _
    "To ESCALATE it, you must choose one of the following statuses:" & vbNewLine & _
    "- ""Assigned""" & vbNewLine & _
    "- ""Pending""" & vbNewLine & _
    "- ""In Progress""", vbOKOnly + vbCritical + vbApplicationModal + vbApplicationModal, "Error"
    cboStatus.SetFocus
    blnValidationError = True
  End If
  
  If blnValidationError = False Then
    Call ComposeEmailAndSend("ESCALATE")
  End If
End Sub
Private Sub btnFillOut_Click()
' FOR TESTING PURPOSES ONLY - REMOVE CODE AND CONTROL BEFORE DISTRIBUTING
'---------------------------------------------------------------------------------------------------
  Dim strLorem As String
  strLorem = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Quisque eget eros ut nunc ultricies rutrum at in lorem. Cras orci mauris, pretium vitae egestas at, pharetra vulputate urna. Vivamus arcu risus, iaculis volutpat rhoncus id, ultrices ac lacus. Proin non urna non justo consequat ornare. Nam sed leo velit, id convallis arcu. Vivamus ac tristique ipsum. In hac habitasse platea dictumst. Cras semper tempor sem, vitae adipiscing quam vehicula quis. Vivamus quis neque dui, a placerat mi. Sed cursus, nisl in pulvinar placerat, enim massa porta nisl, ut semper erat nisl et risus. Sed et volutpat odio. Fusce mi odio, cursus ac ornare non, accumsan eu urna. Donec magna ipsum, fermentum sed consectetur non, fermentum eu justo."
  
  txtUserTSID.Text = "TS91910"
  txtUserName.Text = "John Public"
  txtAssetTag.Text = "ASDF1234"
  txtReleaseVersion.Text = "2012B"
  cboOS.ListIndex = 2
  txtIssueProblem.Text = strLorem
  txtApplication.Text = "Outlook"
  txtErrorMessage.Text = strLorem
  txtTSRStepsTaken.Text = strLorem & vbNewLine & "assigning to SRT"
  txtNextSteps.Text = strLorem
  cboComputerModel.ListIndex = 8
  cboOS.ListIndex = 2
  cboNewRecurring.ListIndex = 1
  cboStatus.ListIndex = 1
End Sub

Private Sub btnClear_Click()
' resets form; clears text fields, resets combo boxes to 0 index, clears listbox for images
'---------------------------------------------------------------------------------------------------
  txtUserTSID.Text = ""
  txtUserName.Text = ""
  txtAssetTag.Text = ""
  txtReleaseVersion.Text = ""
  txtIssueProblem.Text = ""
  txtApplication.Text = ""
  txtErrorMessage.Text = ""
  txtTSRStepsTaken.Text = ""
  txtNextSteps.Text = ""

  cboComputerModel.ListIndex = 0
  cboOS.ListIndex = 0
  cboNewRecurring.ListIndex = 0
  cboStatus.ListIndex = 0
  
  lstAttachments.Clear
  dblTotalMB = 0
  lblTotalMB.Caption = dblTotalMB & "MB"

  txtUserTSID.SetFocus
End Sub

Private Sub btnExit_Click()
' Exits form; prompts if any fields are not clear
'---------------------------------------------------------------------------------------------------
  Dim strPrompt As String

  If txtUserTSID.Text <> "" Or txtUserName.Text <> "" Or txtAssetTag.Text <> "" Or txtReleaseVersion.Text <> "" Or txtIssueProblem.Text <> "" _
  Or txtApplication.Text <> "" _
  Or txtErrorMessage.Text <> "" _
  Or txtTSRStepsTaken.Text <> "" _
  Or txtNextSteps.Text <> "" _
  Or cboComputerModel.ListIndex <> 0 _
  Or cboOS.ListIndex <> 0 _
  Or cboNewRecurring.ListIndex <> 0 _
  Or cboStatus.ListIndex <> 0 _
  Or lstAttachments.ListCount <> 0 Then
    strPrompt = MsgBox("Are you sure you want to exit?" & vbNewLine & "Any information entered will be lost...", vbYesNo + vbQuestion + vbApplicationModal, "Exit")
    Select Case strPrompt
    Case vbYes
      Unload Me
    Case vbNo
      Exit Sub
    Case Else
      MsgBox "Error: Invalid response of """ & strPrompt & """.", vbOKOnly + vbCritical + vbApplicationModal, "Error"
      Exit Sub
    End Select
  Else
    Unload Me
  End If
End Sub