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

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("@IRN").Value = strIRN
    Set oRS = oCmd.Execute
    Do While Not oRS.EOF
        strClient = oRS.Fields.Item("NAMECODE").Value
        strAuthor = oRS.Fields.Item("AUTHOR").Value
    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.Move myDestFolder
    Exit Sub

    'Call MsgBox(Err.Description)

End Sub

Sign In or Register to comment.