Worksite saving document into a folder under a workspace with a script (flat filing enabled)

SField

Hi There

I have a script that saves emails into worksite based on what is in the subject line of the email.

It works well but I would like it to now save into a folder under the case workspace and I can't quite figure out the code for it.

I know the CheckIn part needs to change quite a bit but I can't figure out what to exactly.

Is anyone able to help?

 

Thank you

 

Below is the script I currently use:

 

Sub CADEmails(Item As Outlook.MailItem)

    On Error GoTo ErrorHappened

    Dim itemSubject As String
    itemSubject = Item.Subject
   
    Dim SubPos As Integer
    SubPos = InStr(1, itemSubject, "Case Number", vbTextCompare)
   
    Dim casenoPosStart As Integer
    Dim casenoPosEnd As Integer
    casenoPosStart = InStr(1, itemSubject, "Case Number", vbTextCompare) + 12
    casenoPosEnd = InStr(casenoPosStart + 7, itemSubject, "", vbTextCompare)

    Dim strDatabase As String
    strDatabase = "Wellington"
    Dim strDocType As String
    strDocType = "MIME"
    Dim strClass As String
    strClass = "E-MAIL"
    Dim strSubType As String
    strSubType = ""
    Dim strCaseNo As String
    strCaseNo = LTrim(RTrim(Mid(itemSubject, casenoPosStart, casenoPosEnd - casenoPosStart)))
    Dim strDescription As String
    strDescription = Item.Subject
    Dim strSender As String
    strSender = Item.SenderName
    Dim strTo As String
    strTo = Item.To
    Dim strCC As String
    strCC = Item.CC
    Dim strReceivedTime As Date
    strReceivedTime = Item.ReceivedTime
   
    Dim strClient As String
    strClient = ""
    Dim strRecipient As String
    strRecipient = ""
    Dim strAuthor As String
    strAuthor = ""
    Dim strOperator As String
    strOperator = "CAD"
   
    Dim strIRN As String
    strIRN = LTrim(RTrim(Mid(itemSubject, casenoPosStart, casenoPosEnd - casenoPosStart)))
   
    Set oConn = CreateObject("ADODB.Connection")
    oConn.Open "Provider=SQLOLEDB.1;Data Source=****;Initial Catalog=****;User Id=FileSiteUser;Password=****;"
    Set oCmd = CreateObject("ADODB.Command")
    Set oCmd.ActiveConnection = oConn
    oCmd.CommandType = adCmdStoredProc
    oCmd.CommandText = "upFileSiteIPONZEmails"
    oCmd.Parameters.Refresh
    oCmd.Parameters("@IRN").Value = strIRN
    Set oRS = oCmd.Execute
   
    Do While Not oRS.EOF
        strClient = oRS.Fields.Item("NAMECODE").Value
        strAuthor = oRS.Fields.Item("AUTHOR").Value
        oRS.MoveNext
    Loop
   
   
    Set pNRTDMS = CreateObject("IManage.NRTDMS")
    Set sess = pNRTDMS.Sessions.Add("server")
    Call sess.TrustedLogin
    Set db = sess.Databases.ItemByName("database")
   
    Dim IMDoc As IManage.NRTDocument
    Set IMDoc = pNRTDMS.Sessions(1).Databases(strDatabase).CreateDocument
   
    IMDoc.SetAttributeValueByID nrType, strDocType
    IMDoc.SetAttributeValueByID nrClass, strClass
    IMDoc.SetAttributeValueByID nrSubClass, strSubType
    IMDoc.SetAttributeValueByID nrCustom2, strCaseNo
    IMDoc.SetAttributeValueByID nrDescription, strDescription
    IMDoc.SetAttributeValueByID nrCustom1, strClient
    IMDoc.SetAttributeValueByID nrCustom4, strRecipient
    IMDoc.SetAttributeValueByID nrAuthor, strAuthor
    IMDoc.SetAttributeValueByID nrOperator, strOperator
    IMDoc.SetAttributeValueByID nrCustom22, strReceivedTime
    IMDoc.SetAttributeValueByID nrCustom13, strSender
    IMDoc.SetAttributeValueByID nrCustom14, strTo
    IMDoc.SetAttributeValueByID nrCustom15, strCC
   
    Dim strPath As String
   
    strPath = "c:\temp\temp1.msg"
    If FileOrFolderExists(strPath) Then
        Kill strPath
    End If
   
    Call Item.SaveAs(strPath, 3) 'OIMsg
    Dim fname As String
    fname = strPath
   
    Dim errs As String
   
    IMDoc.CheckIn fname, nrReplaceOriginal, nrDontKeepCheckedOut, errs
   
    Item.UnRead = False
   
    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
    Set myDestFolder = myInbox.Folders("Processed_CAD")

    'Item.Delete
    Item.Move myDestFolder
   
    Exit Sub

ErrorHappened:
   
    'Call MsgBox(Err.Description)

End Sub