Outlook archive of emails (1 Viewer)

[Chrism2]

Hello everyone!

We've been using a database quite successfully for some time to log customer queries.

I used some code from http://www.tek-tips.com/viewthread.cfm?qid=1346884 that allows my colleagues to copy and paste an email from Outlook 2010 into the Access DB field. The code copies the email as a .msg to a network location, and creates a link to it in a memo field.

This had been working perfectly until two days ago, when one PC (only one of twenty!!!) (Win XP, Outlook 2010, Access 2010) stopped pasting the email; but started only pasting the message header. Everyone else can do it.

I've noticed that Outlook has stopped with the "External program trying to access Outlook; ... Allow once / Allow for 10 minutes" has disappeared from this PC. I'm not sure if it's related, but hell, I'm stumped.

Any ideas?

Here is my code:

Private Sub EmailMemo_Change()

    'I got the guts of this sub from Remou on tek-tips.com. S/he told me I can drag and drop an
    'email to a memo field, then gave me the object control code to save the file.
    Dim olApp As Outlook.Application
    Dim olExp As Outlook.Explorer
    Dim olSel As Outlook.Selection
    Dim i, intCounter, intResponse As Integer
    Dim strFileName, strSQL, strFolderPath, strPathAndFile, strMsg As String
    Dim fs As Object
    Dim fsFolder As Object
    Dim blnFolderExists, blnFileExists As Boolean
    
    'This field is used to control attaching emails by dropping them on the field.
    'To allow this the field must be editable. This means the user could accidentally
    'type in the field and trigger the code to attach an email. Therefore, this user
    'verification makes sure the user intentionally dropped an email on the field.
    strMsg = "WARNING: You have triggered the E-mail Attachment Function. CHOOSE CAREFULLY ..." & vbCr & vbCr
    strMsg = strMsg & "If you intended to attach an e-mail to this note, answer Yes below. "
    strMsg = strMsg & "If you did not intend to attach an e-mail and don't know what's going on, "
    strMsg = strMsg & "answer No below." & vbCr & vbCr
    strMsg = strMsg & "Did you intentionally drag and drop an e-mail to attach it to this note?"
    intResponse = MsgBox(strMsg, vbYesNo)
    If intResponse = 7 Then 'No
        Cancel = True
        Exit Sub
    End If
    
    'My network consultant advises not putting too many files in a folder - like our Permanent Images.
    'Therefore, I will separate emails into a new folder each year. This code allows me
    'to never check on it, by creating the folder automatically when the year changes.
    Set fsFolder = CreateObject("Scripting.FileSystemObject")
    strFolderPath = "A:\ADLINEv2\DATA\EMAIL" & Year(Date)
    If fsFolder.FolderExists(strFolderPath) = False Then
        fsFolder.CreateFolder (strFolderPath)
    End If

    'Create the filename as a message file from the ClientID and the NoteID - which will be unique
    strFileName = Me.notesID & "_" & "note" & ".msg"
    
    'Combine for full path and file name
    strPathAndFile = strFolderPath & "\" & strFileName
    
    'Make sure this file does not already exist to avoid overwriting email files when there is a
    'system glitch.
    Set fs = CreateObject("Scripting.FileSystemObject")
    blnFileExists = fs.FileExists(strPathAndFile)
    If blnFileExists = False Then
        'There's not already a file for this client and noteID. This is the way it always
        'should be. But stuff happens. So, I'm checking.
        'Save the email to the filename just created as a message file
        Set olApp = GetObject(, "Outlook.Application")  'First argument is blank to return the currently
                                                        'active Outlook object, otherwise runtime fails
        Set olExp = olApp.ActiveExplorer
        Set olSel = olExp.Selection
        For i = 1 To olSel.Count
            olSel.Item(1).SaveAs strPathAndFile, olMSG
        Next
    Else
        'There's already a file for this client and noteID. This should be impossible,
        'but stuff happens. In this case we notify the user and then re-establish the links
        'so the user can handle it.
        strMsg = "ATTENTION: The system detected an e-mail file already created for this note. "
        strMsg = strMsg & "That e-mail is now linked to this note ID. Please do the following:" & vbCr & vbCr
        strMsg = strMsg & "1. View the e-mail normally." & vbCr
        strMsg = strMsg & "2. If it is the correct e-mail, you don't need to do anything else." & vbCr
        strMsg = strMsg & "3. If it is the wrong e-mail, use the Un-Attach E-mail button to get rid of it. "
        strMsg = strMsg & "Then attach the correct e-mail."
        MsgBox strMsg
    End If
    
    'Update the location field with the location.
    Cancel = True   'To roll back changes caused by the drop.
    Me.emailattachment = strPathAndFile

    UpdateEmailInfo

    Me.Dirty = False    'To save the changes.
    
    Set fsFolder = Nothing
    Set fs = Nothing
    Set olSel = Nothing
    Set olExp = Nothing
    Set olApp = Nothing
    
    
   Me.txtChrs = Len(Me.txtMemo)
End Sub

Private Sub UpdateEmailInfo()
If IsNull(Me.emailattachment) Then

    Me.EmailMemo = ""
    Me.EmailMemo.Locked = False
    Else
    Me.EmailMemo = "EMAIL ATTACHED: Click Here To View"
    Me.EmailMemo.Locked = True
    
End If
End Sub

 

[Chrism2]

Sorry guys! I don't feel good about bumping; but does anyone have any clues here?

Thanks