MS Access 2013 Recurring Database Error

Anne-Marie Hayes
Anne-Marie Hayes used Ask the Experts™
on
I am new to Access.  I inherited a database that I did not create, but am trying to maintain.  This is a work-related database.  I cannot upload the database due to sensitive content. The database contains a form.  The form has a field that allows users to upload files (usually pdf and Outlook msg) to the record.  In the past, the upload feature was working correctly.  Recently, at random times, when trying to upload a file, the following error message appears:  Cannot open database "It may not be a database that your application recognizes, or the file may be corrupt."  After this error appears, users are not able to upload any additional files. In order to correct the problem, I have been obtaining a restored back-up file from our IT department.  I would like to know: 1) Is there a way to view or create an Error Log in Access? 2) Is there a way to debug the error? 3) Any ideas on what is causing the error?
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and Programming
Top Expert 2015

Commented:
uploading the database is not necessary ... you can post the code it runs so we can help.  Perhaps object variables are not being cleaned up or something else is happening in the code. To see the code:

1. go to the design view of the form
2. click the button (presumeably) that the user clicks to launch the code
3. on the property sheet, click in the On Click property on the Events tab -- what does it say?
4.click on the Build button ... to the right.
5. copy and paste the code here

thanks
Paul Cook-GilesSenior Application Developer

Commented:
Is there any uniformity in the file types that generate the message?  Size of the files?

Also, actually storing the file inside the DB can lead to bloat;  if you may modify the DB, I'd recommend moving the files to a secure folder and then saving the link to the files inside the DB.

Yes, you can create an error log in Access;  
[...name of procedure...]
10    On Error GoTo HandleError

[...body of procedure...]

HandleError:
Docmd.setwarnings True
Docmd.Hourglass False
Docmd.RunSQL  "Insert into ErrorLogTb (User, Form, Procedure, Description, ErrorNumber, LineNumber " & _
     "'" & Environ("UserName") & "', 'Form_WorkFrm', 'btnTimeAllocationEmail_Click', '" & Err.Description & "', " & Err.Number & ", " & Erl
Resume ExitSub
EndSub:
     End Sub

Author

Commented:
Crystal:  I have included some screen shots of the form and corresponding code.  There are two fields related to uploading documents:  Attachments and +/- Attachments. When the fields are opened in Form View, they both display the same details.

Paul:  In my troubleshooting attempts, I have not been able to find any commonality among the files when the error occurs.  I think the suggestion to store the files elsewhere is spot-on.  Unfortunately, I am not able to make that change at this time.  I appreciate the error log code, but as a beginner in Access, I don't understand where or how to implement the information.

Thank you both for your replies.
pic0.JPG
pic1.JPG
pic2.JPG
pic3.JPG

Author

Commented:
Paul,

I think I found the heart of the attachment code. Where do you think the best places would be to debug with your code? Any help would be appreciated.
A-M


Option Compare Database
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub WaitTilObjClosed(ObjType As AcObjectType, ObjName As String)
    Do
        DoEvents
        Sleep 1
        If (SysCmd(acSysCmdGetObjectState, ObjType, ObjName) = 0) Then Exit Do
    Loop
End Sub

Function GetText(sFile As String) As String
    Dim nSourceFile As Integer, sText As String
    
    Close
    
    nSourceFile = FreeFile
    
    Open sFile For Input As #nSourceFile
    sText = Input$(LOF(1), 1)
    Close
    
    GetText = sText
End Function


Private Sub Assigned_To_AfterUpdate()
 If Me.Assigned_To = "151" Then '151 lookup for multiple
    DoCmd.OpenForm "frmmultipleassign", , , , acFormAdd
    Me.Contact.Value = ""
    Me.Contact.Enabled = False
    End If
 If Me.Assigned_To = "154" Then '154 lookup for John Doe
    Me.Contact.Value = "FomOffice@mail.mysite.com"
    End If
End Sub



'Private Sub Assigned_To_AfterUpdate()

'End Sub
'    If IsNull(Me!Contact) Or Me!Contact = "" Then
'    'If IsNull(Me!Contact) Then
'    If Len(Me.Contact & vbNullString) = 0 Then
'    MsgBox "OK1"
'    '[PointofContact].Value = Me.Assigned_To.Column(1)
'    Me![Contact] = Me.Assigned_To.Column(1)

    
'    End If
'MsgBox Me![Assigned To]
'MsgBox Me!Contact
'Me![Contact].Requery
'End Sub

'Private Sub Assigned_To_Change()
'   If IsNull([PointofContact]) Or [PointofContact].Value = "" Then
'   MsgBox "OK2"
 '   [PointofContact].Value = [Assigned_To].Value
    
'    End If
'End Sub

Private Sub Attachments_AfterUpdate()
    DoCmd.Save
    
    'Me.Requery
End Sub

Private Sub Attachments_Click()

End Sub

'Private Sub Attachments_Change()
'DoCmd.OpenForm "formok"
'End Sub

Private Sub Attachments_Exit(Cancel As Integer)
'   If IsNull(Me.Text123) And Me.Priority = "eir" Or Me.Priority = "cor" Or Me.Priority = "cmp" Then
''    'continue
      
'        Nosubject = MsgBox("Please provide a subject for this " & [Priority] & Chr(10) & Chr(10), vbOKOnly, "Complete Verification")
''        If completeresponse = vbYes Then
''           Me.Completed_Date = Now()
''
''        ElseIf completeresponse = vbNo Then
''            'End
''            Exit Sub
''        End If

    
''    Me.Text123.SetFocus
    
   DoCmd.OpenForm "formok"
        
    'End If
End Sub



Private Sub btnCopyPDFText_Click()

    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath, CbGetData, sText, sFile As String
    Dim filechk, tmpfldr, emailchk, ResponseOK
    Dim FileType As String, countOf As Long
    
        Dim AcroXApp As Object
        Dim AcroXAVDoc As Object
        Dim AcroXPDDoc As Object

        Set AcroXApp = CreateObject("AcroExch.App")
        AcroXApp.Hide
        
        Dim jsObj As Object
        'Set jsObj = AcroXPDDoc.GetJSObject
            
    Set FSO = CreateObject("scripting.filesystemobject")
      
  '  emailchk = DLookup("[E-mail Address]", "Contacts", "[ID]=" & Nz(Me.[Assigned To], 0))
    
    Call DeletePDFfolder
    Call ClearClipboard
  '  If IsNull(emailchk) = True Then
  '      MsgBox "No Email Address Listed - Unable To Assign Task!" & Chr(10) & Chr(10) & "Please Add A Valid Email Address And Try Again...", vbExclamation, "No Email Address Listed"
        'DoCmd.OpenForm "Contact Details", , , "[ID]=" & Nz(Me.[Assigned To], 0)
'        Exit Sub
 '   End If
    
    If Me.Attachments.AttachmentCount < 1 Then
        MsgBox "There Are No PDF Files Attached!" & Chr(10) & Chr(10) & "Please Check And Try Again...", vbExclamation, "No Attachments"
        Exit Sub
    End If
    
    Call ClearClipboard
    DoCmd.Save

    vPass = ""
    'vPassExcel = ""
    filechk = ""
    tmpfldr = ""

    tmpfldr = "C:\Users\" & Environ$("Username") & "\Desktop\pdffldr"
    
    'Check to see if files exist from previous routine attempt then delete
    filechk = Dir(tmpfldr & "\*.*")
    If filechk <> "" Then
        Kill tmpfldr & "\*.*"
    End If
    
    'If folder exists, delete then create new temporary folder
    If FSO.FolderExists(tmpfldr) = True Then
        FSO.deletefolder (tmpfldr)
    End If
    If FSO.FolderExists(tmpfldr) = False Then
        'On Error GoTo Contin
        FSO.CreateFolder (tmpfldr)
        'On Error GoTo Contin
    End If
    
'Contin:

    Call SaveAttachments("C:\Users\" & Environ$("Username") & "\Desktop\pdffldr")
    
    FileType = Dir$(tmpfldr & "\*.pdf")
    Do Until FileType = ""
        countOf = (countOf + 1)
        FileType = Dir$()
    Loop
    
'******************************************************
    'If FSO.GetFolder(tmpfldr).Files.Count > 1 Then
    If countOf > 1 Then
        DoCmd.OpenForm "frmFileSearch3"
        WaitTilObjClosed acForm, "frmFileSearch3"
    Else
    
        vPass = Dir(tmpfldr & "\*.pdf")
        
 '       Dim AcroXApp As Object
 '       Dim AcroXAVDoc As Object
 '       Dim AcroXPDDoc As Object

 '       Set AcroXApp = CreateObject("AcroExch.App")
 '       AcroXApp.Hide

        Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
        AcroXAVDoc.Open tmpfldr & "\" & vPass, "Acrobat"

        AcroXAVDoc.BringToFront

        Set AcroXPDDoc = AcroXAVDoc.GetPDDoc

        'Dim jsObj As Object
        Set jsObj = AcroXPDDoc.GetJSObject
       
'*************************COMPARE THESE TWO LINES OF CODE BELOW - RUN AND CHECK EACH ONE!!!!!*************************

'**********This line copies the plain-text only, which includes the body of the letter and some formatting

        jsObj.SaveAs tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt", "com.adobe.acrobat.plain-text"
        
        
'**********This line copies EVERYTHING from the PDF - All characters - maybe stuff you don't want - not formatted

        'jsObj.SaveAs tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt", "com.adobe.acrobat.accesstext"
        
'*********************************************************************************************************************
        
        AcroXAVDoc.Close False
        AcroXApp.Hide
        AcroXApp.Exit
        
        sFile = tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt"
        
        sText = GetText(sFile)
        
        Me.Description = ""
        
        Me.Description = sText
        
        sText = ""
              
        'ShellExecute 0, "Open", vPass, "", tmpfldr & "\", 1
        
    '    MsgBox "Copying PDF Text...", , "Copying"
        
        'Call PauseAgain(2)
        'SendKeys "^a", True
        
       'Call PauseAgain(2)
       ' SendKeys "^c"
        
        'Call PauseAgain(2)
        'SendKeys "^q"
    
        'MsgBox "Completing Copy...", , "Copying"
            
    End If
'******************************************************

   ' Me.Description = ""
  '  If Me.ckBoxTextType = True Then
       ' Me.Description.SetFocus
     '   DoCmd.RunCommand acCmdPaste
  '  Else
  '      CbGetData = ClipBoard_GetData()
       ' Me.Description = CbGetData
   ' End If
        
   filechk = Dir(tmpfldr & "\*.*")
    If filechk <> "" Then
        Kill tmpfldr & "\*.*"
    End If
    
    If FSO.FolderExists(tmpfldr) = True Then
        FSO.deletefolder (tmpfldr)
    End If
    'comment out if problem
    'Call ClearClipboard
    
    MsgBox "Copy Successful!", , "Copy Complete"
    Me.cmdClose.SetFocus
    Me.Refresh
    Call DeletePDFfolder
End Sub

Private Sub Check138_Click()
    If Me.Check138 = True Then
        Text136.Enabled = True
        Text148.Enabled = True
    Else
        Text136.Enabled = False
        Text148.Enabled = False
    End If
End Sub

Private Sub Check189_Click()
If Me.Check189 = True Then
Me.Text193.Enabled = True
End If
If Me.Check189 = False Then
Me.Text193.Enabled = False
End If
End Sub

Private Sub Check191_Click()
If Me.Check191 = True Then
Me.Text195.Enabled = True
End If
If Me.Check191 = False Then
Me.Text195.Enabled = False
End If

End Sub

Private Sub Closeout_Date_AfterUpdate()
 If IsNull(Me.Completed_Date) = False And IsNull(Me.Closeout_Date) = True Then
       Me.Status = "Completed"
    End If

    If IsNull(Me.Completed_Date) = False And IsNull(Me.Closeout_Date) = False Then
       Me.Status = "Closed"
    End If

    If IsNull(Me.Completed_Date) = True And IsNull(Me.Closeout_Date) = True Then
        Me.Status = "In progress"
    End If

   If IsNull(Me.Completed_Date) = True And IsNull(Me.Closeout_Date) = False Then
        Me.Status = "Closed"
    End If
    Me.Refresh
    'Me.Requery
End Sub

Private Sub Closeout_Date_DblClick(Cancel As Integer)
    Me.Closeout_Date = Null
    Call Closeout_Date_AfterUpdate
End Sub

'Private Sub Closeout_Date_Change()
'   If Len(Me.Completed_Date) > 0 And Len(Me.Closeout_Date) = 0 Then
'        Me.Status = "Completed"
'    End If
'
'    If Len(Me.Completed_Date) > 0 And Len(Me.Closeout_Date) > 0 Then
'        Me.Status = "Closed"
'    End If
'
'    If Len(Me.Completed_Date) = 0 And Len(Me.Closeout_Date) = 0 Then
'        Me.Status = "In progress"
'    End If
'
'    If Len(Me.Completed_Date) = 0 And Len(Me.Closeout_Date) > 0 Then
'        Me.Status = "Closed"
'    End If
    
'End Sub

Private Sub cmdEmail_Click()

    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim filechk, tmpfldr, emailchk
    Dim FileType As String, countOf As Long
        
    Set FSO = CreateObject("scripting.filesystemobject")
    
   'Me.Requery
   
    
'    emailchk = DLookup("[E-mail Address]", "Contacts", "[ID]=" & Nz(Me.[Assigned To], 0))
    
    If Me.Attachments.AttachmentCount < 1 Then
        MsgBox "There Is No PDF File Attached!" & Chr(10) & Chr(10) & "Please Check And Try Again...", vbExclamation, "No Attachments"
        'Exit Sub
        DoCmd.GoToControl "Attachments"
        DoCmd.RunCommand acCmdManageAttachments
        Me.Refresh
        'me.requery
    End If
    
'    If IsNull(emailchk) = True Then
'        MsgBox "No Email Address Listed - Unable To Assign Task!" & Chr(10) & Chr(10) & "Please Add A Valid Email Address And Try Again...", vbExclamation, "No Email Address Listed"
        'DoCmd.OpenForm "Contact Details", , , "[ID]=" & Nz(Me.[Assigned To], 0)
'        Exit Sub
'    End If
    
    vPass = ""
   ' vPassExcel = ""
    filechk = ""
    tmpfldr = ""
    'Temporary folder to be created on current user's desktop
    tmpfldr = "C:\Users\" & Environ$("Username") & "\Desktop\pdffldr"
    
    'Check to see if files exist from previous routine attempt then delete
    filechk = Dir(tmpfldr & "\*.*")
    If filechk <> "" Then
        Kill tmpfldr & "\*.*"
    End If
    
    
    'If folder exists, delete then create new temporary folder
    If FSO.FolderExists(tmpfldr) = True Then
        FSO.deletefolder (tmpfldr)
    End If
    If FSO.FolderExists(tmpfldr) = False Then
        'On Error GoTo Contin
        FSO.CreateFolder (tmpfldr)
        'On Error GoTo Contin
    End If
    
'Contin:

    Call SaveAttachments("C:\Users\" & Environ$("Username") & "\Desktop\pdffldr")
    'Call SaveAttachmentExcel("C:\Users\" & Environ$("Username") & "\Desktop\pdffldr")
    
    FileType = Dir$(tmpfldr & "\*.pdf")
    Do Until FileType = ""
        countOf = (countOf + 1)
        FileType = Dir$()
    Loop
    'MsgBox countOf
    
    'If FSO.GetFolder(tmpfldr).Files.Count > 1 Then
    If countOf > 1 Then
        DoCmd.OpenForm "frmFileSearch2"
        WaitTilObjClosed acForm, "frmFileSearch2"
    Else
        'Continue
        vPass = tmpfldr & "\" & Dir(tmpfldr & "\*.pdf")
    End If
    
'***************************************
'Cancel From Multiple Attachment Form
    If vPass = "" Then
        filechk = Dir(tmpfldr & "\*.*")
        If filechk <> "" Then
            Kill tmpfldr & "\*.*"
        End If
        
        If FSO.FolderExists(tmpfldr) = True Then
            FSO.deletefolder (tmpfldr)
        End If
        Exit Sub
    End If
    
'Make change here!!!!!
'****************************************************
  '  Name tmpfldr & "\eir letter response v1.xlsm" As tmpfldr & "\" & Me.Title & ".xlsm"
'****************************************************

  '  vPassExcel = tmpfldr & "\" & Me.Title & ".xlsm"
    Call CreateEmail
    
    filechk = Dir(tmpfldr & "\*.*")
    If filechk <> "" Then
        Kill tmpfldr & "\*.*"
    End If
    
    If FSO.FolderExists(tmpfldr) = True Then
        FSO.deletefolder (tmpfldr)
    End If

'    If Me.Attachments.AttachmentCount < 1 Then
'        MsgBox "There Is No PDF File Attached!" & Chr(10) & Chr(10) & "Please Check And Try Again...", vbExclamation, "No Attachments"
'        'Exit Sub
'        DoCmd.GoToControl "Attachments"
'        DoCmd.RunCommand acCmdManageAttachments
'        Me.Refresh
        'me.requery
'    End If
    
'    If IsNull(emailchk) = True Then
'        MsgBox "No Email Address Listed - Unable To Assign Task!" & Chr(10) & Chr(10) & "Please Add A Valid Email Address And Try Again...", vbExclamation, "No Email Address Listed"
'        DoCmd.OpenForm "Contact Details", , , "[ID]=" & Nz(Me.[Assigned To], 0)
'        Exit Sub
'    End If


End Sub




Public Function PauseAgain(NumberOfSeconds As Variant)
On Error GoTo Err_PauseAgain

    Dim PauseTime As Variant, start As Variant

    PauseTime = NumberOfSeconds
    start = Timer
    Do While Timer < start + PauseTime
    DoEvents
    Loop

Exit_PauseAgain:
    Exit Function

Err_PauseAgain:
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "PauseAgain()"
    Resume Exit_PauseAgain

End Function

Private Sub CreateEmail()

Dim sTo As String
Dim sCC As String
Dim sBCC As String
Dim sSub As String
Dim sBody As String
Dim strCC As String
Dim outApp As Object
Dim outMail As Object
Dim varPress, varPress2 As Variant



Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim filechk, tmpfldr, emailchk
Dim FileType As String, countOf As Long
Dim str(100), n, EmailVar As String
Dim strSQL, strSQL2 As String
Dim stDocName As String
Dim Response
Dim cnt

Set FSO = CreateObject("scripting.filesystemobject")

'strSQL = "SELECT  direm, pointofcontact FROM qrymultassigntolist where (((title)=[forms]![task details]![title]))" 'Record Source is table or query
'strSQL = "SELECT multdirem, multpocem, direm, pointofcontact, title FROM qrymultassigntolist where (((title)=[forms]![task details]![title]))" 'Record Source is table or query
DoCmd.SetWarnings False
DoCmd.OpenQuery "qrymultassigntolist"
DoCmd.SetWarnings True
strSQL = "SELECT multdirem, multpocem, direm, pointofcontact FROM tblqrymultassign" 'Record Source is table or query
Set db = CurrentDb
Set rst = db.OpenRecordset(strSQL)
cnt = rst.RecordCount
n = 1

strMess = "You are about to send an email message to the current user." & vbCrLf & vbCrLf
strMess = strMess & "Do you wish to continue?"

strStyle = vbYesNo
strTitle = "Send Notification"

varPress2 = MsgBox(strMess, strStyle, strTitle)



If varPress2 = vbYes Then
    ' Get the email address from the current form control
   ' sTo = DLookup("[E-mail Address]", "Contacts", "[ID]=" & Nz(Me.[Assigned To]), Dlookup ("[multdiremail]","qrymultassign","[title]=" & nz(me.[title])

EmailVar = "" 'Variable To Create Formatted Multiple Email List
With rst
Do Until rst.EOF
    If rst.EOF = True Then
        End
    End If
    str(n) = rst!multdirem & "; " & rst!multpocem & "; " & rst!direm & "; " & rst!PointofContact
    If n = cnt Then 'If-Then-Else To Drop Last Comma If End Of Field Or RecordSet (n = cnt)
        EmailVar = EmailVar & str(n)
    Else
        EmailVar = EmailVar & str(n) & "; "
    End If
    n = n + 1
    rst.MoveNext
Loop
End With
rst.Close
       sTo = EmailVar 'DLookup("[E-mail Address]", "Contacts", "[ID]=" & Nz(Me.[Assigned To], 0))
    
    
    '  Set the subject
    sSub = Replace("FAA Letter: |", "|", Nz(Me.Title, ""))
    
If Me.Priority = "EIR" Then
    ' Build the body of the email
    sBody = "Please send rely me " & [Liaison] & Chr(10) & Chr(10) _
    & "The response from your office:" & Chr(10) & Chr(10) _
    & "1.  must be on company letterhead" & Chr(10) _
    & "2.  must be addressed to theassigned, see above" & Chr(10) _
    & "3.  must determine if there is/was a violation" & Chr(10) _
    & "    a.  If 'no', provide details and substantiation" & Chr(10) _
    & "    b.  If 'yes', provide details and corrective action taken, include all objective evidence, including PFCRs and target publish date, as applicable" & Chr(10) _
    & "4.  must be signed by you (or for you in your absence)" & Chr(10) _
    & "5.  must be received in this office by Due Date: " & Format([InitDirRespRec], "m/d/yy") & Chr(10) & Chr(10) _
    & "Your response will be used." & Chr(10) & Chr(10) _
    & "Failure to respond could lead to possible  against the company." & Chr(10) & Chr(10) _
    & "In the event that the letter requires a response from multiple departments, those individuals will be addressed in the 'To:' field of this email.  You should perform a review of the letter and prepare a response for the areas that fall under your responsibility.  " & Chr(10) & Chr(10) _
    & "If this letter from the office has been incorrectly addressed." & Chr(10) & Chr(10) _
    
    


End If

        If Not (Me.Priority = "EIR") Then
        'If Me.Priority = "CMP" Or Me.Priority = "COR" Then
        
        strMess = "Does this " & [Priority] & " require a response?" & vbCrLf & vbCrLf
        
        strStyle = vbYesNo
        strTitle = "Response required"
        
        varPress = MsgBox(strMess, strStyle, strTitle)
               
            If varPress = vbYes Then
        
                sBody = "Please reply to me " & [Liaison] & Chr(10) _
                   & "The response from your office:" & Chr(10) & Chr(10) _
                   & "1.  must be on company letterhead" & Chr(10) & Chr(10) _
                   & "2.  must be addressed to the Liaison assigned, see above" & Chr(10) & Chr(10) _
                   & "3.  must be signed by you (or for you in your absence)" & Chr(10) & Chr(10) _
                   & "4.  must be received in this office by Due Date: " & Format([InitDirRespRec], "m/d/yy") & Chr(10) & Chr(10) _
                   & "A cover letter from this office will be ." & Chr(10) & Chr(10) _
                   & "In the event that the letter requires a response from multiple departments, those individuals will be addressed in the 'To:' field of this email.  You should perform a review of the letter and prepare a response for the areas that fall under your responsibility. " & Chr(10) & Chr(10) _
                   & "If this letter from the office has been incorrectly addressed, or you are not the responsible party, please contact the  office immediately." & Chr(10) & Chr(10) _

                   


            End If
      
      If varPress = vbNo Then
      
       sBody = "Please reply to me." & Chr(10) & Chr(10) _
        & "In the event that this letter from the office has been incorrectly addressed, or you are not the responsible party, please contact the office immediately. " & Chr(10) & Chr(10) _
        & "After the initial confirmation of receipt, all future correspondence will be sent to the assigned: " & ([Liaison])
        
        End If
    End If
    
    
    'IIf(Me.Form.Description.TextFormat = 1, PlainText(Me.Description & "Due: " & Me.[Due Date]), Me.Description & " Due: " & Me.[Due Date])
    
    ' Create the email
    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(0)
    'Set OutMail = OutApp.CreateItemFromTemplate("C:\Vacation Request.msg")                   '***Uses Template Instead - Would Not Recommend***

    sCC = [Contact] & ";FTA@mail.mysite.com;CASSTech@corp.mysite.com "
    sBCC = ""
    
  
    With outMail
        .To = sTo
        .cc = sCC
        .BCC = sBCC
        .ReplyRecipients.Add ("FTA@mail.mysite.com")
        .Subject = sSub
        .Body = sBody
        .Attachments.Add vPass
        '.Attachments.Add vPassExcel
        '.FlagDueBy = Me.[Due Date] + 1
        .Display          ' THis will display the email, but not send it
        '.Send            ' THis will send the email
    End With
    Set outMail = Nothing
    Set outApp = Nothing
    Call DeletePDFfolder
End If
If varPress2 = vbNo Then
'    filechk = ""
'    tmpfldr = ""
'    'Temporary folder to be created on current user's desktop
'    tmpfldr = "C:\Users\" & Environ$("Username") & "\Desktop\pdffldr"
'
'    'Check to see if files exist from previous routine attempt then delete
'    filechk = Dir(tmpfldr & "\*.*")
'    If filechk <> "" Then
'        Kill tmpfldr & "\*.*"
'    End If
'
'    'If folder exists, delete then create new temporary folder
'    If FSO.FolderExists(tmpfldr) = True Then
'        FSO.deletefolder (tmpfldr)
'    End If
''    If FSO.FolderExists(tmpfldr) = False Then
'        'On Error GoTo Contin
''        FSO.CreateFolder (tmpfldr)
'        'On Error GoTo Contin
''    End If
Call DeletePDFfolder
End If


End Sub


Sub SendEmail(EmailContent As String)

    Dim OutlookApp As Object
 
    Set OutlookApp = CreateObject("Outlook.Application")
    With OutlookApp.CreateItem(olTaskItem)
        .To = "jane.doe@mysite.com"
        .Subject = "Operational Risk - Key Risk Metric Data Entry Due"
        .Body = EmailContent
        .Importance = 2
        .ReminderSet = False 'True
        .ReminderTime = DateAdd("n", 2, Now)
        '.FlagDueBy = DateAdd("n", 2, Now)
        .Display
        '.send
    End With
    
End Sub

Private Sub cmdEmail_Exit(Cancel As Integer)
Dim completeresponse

    If IsNull(Me.Completed_Date) And Me.Priority = "vdr" Or Me.Priority = "man" Or Me.Priority = "cert. ltr." Or Me.Priority = "opr" Or Me.Priority = "int'l auth." Or Me.Priority = "cce" Or Me.Priority = "FTA request" Or Me.Priority = "fdx flt ltr" Or Me.Priority = "safa (int'l)" Then
    'continue

        
    
        completeresponse = MsgBox("Should this " & [Priority] & " be marked complete today?" & Chr(10) & Chr(10) & "Click Yes To Complete Today Or No To Manually Update Completed Date....", vbYesNo, "Complete Verification")
        If completeresponse = vbYes Then
           Me.Completed_Date = Now()
           Me.Status = "Completed"
        
        ElseIf completeresponse = vbNo Then
            'End
            Exit Sub
        End If
    End If
End Sub

Private Sub cmdSaveAndNew_Exit(Cancel As Integer)
DoCmd.OpenForm "formok"

End Sub

Private Sub Combo158_GotFocus()
If Me.Text167.Value < Me.Text148.Value Then
Me.Text167.Value = Me.Text148.Value
Else
Me.Text167.Value = Me.Dir_Internal_Due_Date.Value
End If
End Sub

Private Sub Command150_Click()
Call SendEmail("test")
End Sub



Private Sub Command155_Click()
Me.Description = Null
End Sub

Private Sub Command171_Click()
Dim FSO As Object
    Dim FromPath As String
    Dim ToPath, CbGetData, sText, sFile As String
    Dim filechk, tmpfldr, emailchk, ResponseOK
    Dim FileType As String, countOf As Long
    
        Dim AcroXApp As Object
        Dim AcroXAVDoc As Object
        Dim AcroXPDDoc As Object

        Set AcroXApp = CreateObject("AcroExch.App")
        AcroXApp.Hide
        
        Dim jsObj As Object
        'Set jsObj = AcroXPDDoc.GetJSObject
            
    Set FSO = CreateObject("scripting.filesystemobject")
      
 '   emailchk = DLookup("[E-mail Address]", "Contacts", "[ID]=" & Nz(Me.[Assigned To], 0))
    
    Call DeletePDFfolder
    Call ClearClipboard
  '  If IsNull(emailchk) = True Then
  '      MsgBox "No Email Address Listed - Unable To Assign Task!" & Chr(10) & Chr(10) & "Please Add A Valid Email Address And Try Again...", vbExclamation, "No Email Address Listed"
   '     'DoCmd.OpenForm "Contact Details", , , "[ID]=" & Nz(Me.[Assigned To], 0)
   '     Exit Sub
  '  End If
    
    If Me.Attachments.AttachmentCount < 1 Then
        MsgBox "There Are No PDF Files Attached!" & Chr(10) & Chr(10) & "Please Check And Try Again...", vbExclamation, "No Attachments"
        Exit Sub
    End If
    
    Call ClearClipboard
    DoCmd.Save

    vPass = ""
    'vPassExcel = ""
    filechk = ""
    tmpfldr = ""

    tmpfldr = "C:\Users\" & Environ$("Username") & "\Desktop\pdffldr"
    
    'Check to see if files exist from previous routine attempt then delete
    filechk = Dir(tmpfldr & "\*.*")
    If filechk <> "" Then
        Kill tmpfldr & "\*.*"
    End If
    
    'If folder exists, delete then create new temporary folder
    If FSO.FolderExists(tmpfldr) = True Then
        FSO.deletefolder (tmpfldr)
    End If
    If FSO.FolderExists(tmpfldr) = False Then
        'On Error GoTo Contin
        FSO.CreateFolder (tmpfldr)
        'On Error GoTo Contin
    End If
    
'Contin:

    Call SaveAttachments("C:\Users\" & Environ$("Username") & "\Desktop\pdffldr")
    
    FileType = Dir$(tmpfldr & "\*.pdf")
    Do Until FileType = ""
        countOf = (countOf + 1)
        FileType = Dir$()
    Loop
    
'******************************************************
    'If FSO.GetFolder(tmpfldr).Files.Count > 1 Then
    If countOf > 1 Then
        DoCmd.OpenForm "frmFileSearch3"
        WaitTilObjClosed acForm, "frmFileSearch3"
    Else
    
        vPass = Dir(tmpfldr & "\*.pdf")
        
 '       Dim AcroXApp As Object
 '       Dim AcroXAVDoc As Object
 '       Dim AcroXPDDoc As Object

 '       Set AcroXApp = CreateObject("AcroExch.App")
 '       AcroXApp.Hide

        Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
        AcroXAVDoc.Open tmpfldr & "\" & vPass, "Acrobat"

        AcroXAVDoc.BringToFront

        Set AcroXPDDoc = AcroXAVDoc.GetPDDoc

        'Dim jsObj As Object
        Set jsObj = AcroXPDDoc.GetJSObject
       
'*************************COMPARE THESE TWO LINES OF CODE BELOW - RUN AND CHECK EACH ONE!!!!!*************************

'**********This line copies the plain-text only, which includes the body of the letter and some formatting

        jsObj.SaveAs tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt", "com.adobe.acrobat.plain-text"
        
        
'**********This line copies EVERYTHING from the PDF - All characters - maybe stuff you don't want - not formatted

        'jsObj.SaveAs tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt", "com.adobe.acrobat.accesstext"
        
'*********************************************************************************************************************
        
        AcroXAVDoc.Close False
        AcroXApp.Hide
        AcroXApp.Exit
        
        rFile = tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt"
        
        rText = GetText(sFile)
        
        Me.FAAResponse = ""
        
        Me.FAAResponse = rText
        
        rText = ""
              
        'ShellExecute 0, "Open", vPass, "", tmpfldr & "\", 1
        
    '    MsgBox "Copying PDF Text...", , "Copying"
        
        'Call PauseAgain(2)
        'SendKeys "^a", True
        
       'Call PauseAgain(2)
       ' SendKeys "^c"
        
        'Call PauseAgain(2)
        'SendKeys "^q"
    
        'MsgBox "Completing Copy...", , "Copying"
            
    End If
'******************************************************

   ' Me.Description = ""
  '  If Me.ckBoxTextType = True Then
       ' Me.Description.SetFocus
     '   DoCmd.RunCommand acCmdPaste
  '  Else
  '      CbGetData = ClipBoard_GetData()
       ' Me.Description = CbGetData
   ' End If
        
   filechk = Dir(tmpfldr & "\*.*")
    If filechk <> "" Then
        Kill tmpfldr & "\*.*"
    End If
    
    If FSO.FolderExists(tmpfldr) = True Then
        FSO.deletefolder (tmpfldr)
    End If
    'comment out if problem
    'Call ClearClipboard
    
    MsgBox "Copy Successful!", , "Copy Complete"
    Me.cmdClose.SetFocus
    Me.Refresh
    Call DeletePDFfolder
End Sub

Private Sub Command172_Click()


Dim str(20), n, EmailVar As String
Dim strSQL, strSQL2 As String
Dim stDocName As String
Dim Response
Dim cnt

'strSQL = "SELECT multdirem, multpocem,direm, pocem FROM qrymultassigntolist"
strSQL = "SELECT multdirem, multpocem,direm, pocem FROM qrymultassigntolist where (((title)=[forms]![task details]![title]))" 'Record Source is table or query
Set db = CurrentDb
Set rst = db.OpenRecordset(strSQL)
cnt = rst.RecordCount
n = 1
EmailVar = "" 'Variable To Create Formatted Multiple Email List
With rst
Do Until rst.EOF
    If rst.EOF = True Then
        End
    End If
    str(n) = rst!multdirem & ", " & rst!multpocem & ", " & rst!direm & ", " & rst!pocem
    If n = cnt Then 'If-Then-Else To Drop Last Comma If End Of Field Or RecordSet (n = cnt)
        EmailVar = EmailVar & str(n)
    Else
        EmailVar = EmailVar & str(n) & ", "
    End If
    n = n + 1
    rst.MoveNext
Loop
End With
rst.Close
MsgBox EmailVar 'This Is What Your Formatted Email Variable Will Look Like....

End Sub

Private Sub Command176_Click()
Dim FSO As Object
    Dim FromPath As String
    Dim ToPath, CbGetData, rText, rFile As String
    Dim filechk, tmpfldr, emailchk, ResponseOK
    Dim FileType As String, countOf As Long
    
        Dim AcroXApp As Object
        Dim AcroXAVDoc As Object
        Dim AcroXPDDoc As Object

        Set AcroXApp = CreateObject("AcroExch.App")
        AcroXApp.Hide
        
        Dim jsObj As Object
        'Set jsObj = AcroXPDDoc.GetJSObject
            
    Set FSO = CreateObject("scripting.filesystemobject")
      
 '   emailchk = DLookup("[E-mail Address]", "Contacts", "[ID]=" & Nz(Me.[Assigned To], 0))
    
    Call DeletePDFfolder
    Call ClearClipboard
  '  If IsNull(emailchk) = True Then
  '      MsgBox "No Email Address Listed - Unable To Assign Task!" & Chr(10) & Chr(10) & "Please Add A Valid Email Address And Try Again...", vbExclamation, "No Email Address Listed"
   '     'DoCmd.OpenForm "Contact Details", , , "[ID]=" & Nz(Me.[Assigned To], 0)
   '     Exit Sub
  '  End If
    
    If Me.Attachments.AttachmentCount < 1 Then
        MsgBox "There Are No PDF Files Attached!" & Chr(10) & Chr(10) & "Please Check And Try Again...", vbExclamation, "No Attachments"
        Exit Sub
    End If
    
    Call ClearClipboard
    DoCmd.Save

    vPass = ""
    'vPassExcel = ""
    filechk = ""
    tmpfldr = ""

    tmpfldr = "C:\Users\" & Environ$("Username") & "\Desktop\pdffldr"
    
    'Check to see if files exist from previous routine attempt then delete
    filechk = Dir(tmpfldr & "\*.*")
    If filechk <> "" Then
        Kill tmpfldr & "\*.*"
    End If
    
    'If folder exists, delete then create new temporary folder
    If FSO.FolderExists(tmpfldr) = True Then
        FSO.deletefolder (tmpfldr)
    End If
    If FSO.FolderExists(tmpfldr) = False Then
        'On Error GoTo Contin
        FSO.CreateFolder (tmpfldr)
        'On Error GoTo Contin
    End If
    
'Contin:

    Call SaveAttachments("C:\Users\" & Environ$("Username") & "\Desktop\pdffldr")
    
    FileType = Dir$(tmpfldr & "\*.pdf")
    Do Until FileType = ""
        countOf = (countOf + 1)
        FileType = Dir$()
    Loop
    
'******************************************************
    'If FSO.GetFolder(tmpfldr).Files.Count > 1 Then
    If countOf > 1 Then
        DoCmd.OpenForm "frmFileSearch3"
        WaitTilObjClosed acForm, "frmFileSearch3"
    Else
    
        vPass = Dir(tmpfldr & "\*.pdf")
        
 '       Dim AcroXApp As Object
 '       Dim AcroXAVDoc As Object
 '       Dim AcroXPDDoc As Object

 '       Set AcroXApp = CreateObject("AcroExch.App")
 '       AcroXApp.Hide

        Set AcroXAVDoc = CreateObject("AcroExch.AVDoc")
        AcroXAVDoc.Open tmpfldr & "\" & vPass, "Acrobat"

        AcroXAVDoc.BringToFront

        Set AcroXPDDoc = AcroXAVDoc.GetPDDoc

        'Dim jsObj As Object
        Set jsObj = AcroXPDDoc.GetJSObject
       
'*************************COMPARE THESE TWO LINES OF CODE BELOW - RUN AND CHECK EACH ONE!!!!!*************************

'**********This line copies the plain-text only, which includes the body of the letter and some formatting

        jsObj.SaveAs tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt", "com.adobe.acrobat.plain-text"
        
        
'**********This line copies EVERYTHING from the PDF - All characters - maybe stuff you don't want - not formatted

        'jsObj.SaveAs tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt", "com.adobe.acrobat.accesstext"
        
'*********************************************************************************************************************
        
        AcroXAVDoc.Close False
        AcroXApp.Hide
        AcroXApp.Exit
        
        rFile = tmpfldr & "\" & Left(vPass, Len(vPass) - 4) & ".txt"
        
        rText = GetText(rFile)
        
        Me.txtresponsepdf = ""
        
        Me.txtresponsepdf = rText
        
        rText = ""
              
        'ShellExecute 0, "Open", vPass, "", tmpfldr & "\", 1
        
    '    MsgBox "Copying PDF Text...", , "Copying"
        
        'Call PauseAgain(2)
        'SendKeys "^a", True
        
       'Call PauseAgain(2)
       ' SendKeys "^c"
        
        'Call PauseAgain(2)
        'SendKeys "^q"
    
        'MsgBox "Completing Copy...", , "Copying"
            
    End If
'******************************************************

   ' Me.Description = ""
  '  If Me.ckBoxTextType = True Then
       ' Me.Description.SetFocus
     '   DoCmd.RunCommand acCmdPaste
  '  Else
  '      CbGetData = ClipBoard_GetData()
       ' Me.Description = CbGetData
   ' End If
        
   filechk = Dir(tmpfldr & "\*.*")
    If filechk <> "" Then
        Kill tmpfldr & "\*.*"
    End If
    
    If FSO.FolderExists(tmpfldr) = True Then
        FSO.deletefolder (tmpfldr)
    End If
    'comment out if problem
    'Call ClearClipboard
    
    MsgBox "Copy Successful!", , "Copy Complete"
    Me.cmdClose.SetFocus
    Me.Refresh
    Call DeletePDFfolder
End Sub

Private Sub Completed_Date_AfterUpdate()
 If IsNull(Me.Completed_Date) = False And IsNull(Me.Closeout_Date) = True Then
       Me.Status = "Completed"
    End If

    If IsNull(Me.Completed_Date) = False And IsNull(Me.Closeout_Date) = False Then
       Me.Status = "Closed"
    End If

    If IsNull(Me.Completed_Date) = True And IsNull(Me.Closeout_Date) = True Then
        Me.Status = "In progress"
    End If

   If IsNull(Me.Completed_Date) = True And IsNull(Me.Closeout_Date) = False Then
        Me.Status = "Closed"
    End If
    Me.Refresh
    'Me.Requery
End Sub

Private Sub Completed_Date_DblClick(Cancel As Integer)
Me.Completed_Date = Null
Call Completed_Date_AfterUpdate
End Sub




'Private Sub Completed_Date_AfterUpdate()
'
'
'    If Len(Me.Completed_Date) > 0 And Len(Me.Closeout_Date) = 0 Then
'    Me.Status = "Completed"
'    End If
'    If Len(Me.Completed_Date) > 0 And Len(Me.Closeout_Date) > 0 Then
'    Me.Status = "Closed"
'    Else
'    Me.Status = "In progress"
'    End If
    
'End Sub
    



Private Sub Due_Date_AfterUpdate()
[InitDirRespRec] = [due date] - 2
Me.Refresh
If Me.Text167.Value < Me.Text148.Value Then
Me.Text167.Value = Me.Text148.Value
Else
Me.Text167.Value = Me.Dir_Internal_Due_Date.Value
End If

End Sub

Private Sub Due_Date_Change()
[InitDirRespRec] = [due date] - 2
End Sub

Private Sub Due_Date_DblClick(Cancel As Integer)
Me.Due_Date = Null
Me.InitDirRespRec = Null
End Sub

Private Sub Due_Date_Dirty(Cancel As Integer)
If Me.Text167.Value < Me.Text148.Value Then
Me.Text167.Value = Me.Text148.Value
Else
Me.Text167.Value = Me.Dir_Internal_Due_Date.Value
End If
End Sub

Private Sub EmailOverdueReminder_Click()
'Private Sub reminderddtest()
Dim db As Database, rst As Recordset, rst2 As Recordset
    Dim strTable As String
    Dim strSQL, strSQL2 As String
    Dim stDocName As String
    Dim Response2, ODdays As String
    Dim OutlookApp As Object
 
    Set OutlookApp = CreateObject("Outlook.Application")
        
    Response2 = MsgBox("Sending Task Reminder(s)!" & Chr(10) & Chr(10) & "Click OK To Continue Or Cancel To Stop....", vbOKCancel, "Task Reminder(s)")
        If Response2 = vbOK Then
            strSQL = "SELECT ID, Title, [Assigned To], [Start Date], [Due Date], Liaison, [E-mail Address], [Before Due] FROM qryOverDueEIR"
            Set db = CurrentDb
            
            Set rst = db.OpenRecordset(strSQL)
            
            With rst
            
            Do Until rst.EOF
            
                If rst.EOF = True Then
                    'End
                    Exit Sub
                End If
                
                ODdays = rst![Before Due]
                If rst![Before Due] < 1 Then
                'Reminder Text for Overdue and coming due emails
                    ODdays = "Reminder: Response Due Date Was " & rst![due date] & " And Is Now " & Abs(rst![Before Due]) & " Days Overdue. Please Submit as soon as possible."
                Else
                    ODdays = "Reminder: Response Is Due In " & rst![Before Due] & " Days. Please Submit By " & rst![due date] & "...Thank You..."
                End If
                
                            rst.MoveNext
            Loop
            End With
            rst.Close
            
            ElseIf Response2 = vbCancel Then
                'End
                Exit Sub
        End If
End Sub




Private Sub FTA_Closeout_Letter_BeforeUpdate(Cancel As Integer)

End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
If Me.Text167.Value < Me.Text148.Value Then
Me.Text167.Value = Me.Text148.Value
Else
Me.Text167.Value = Me.Dir_Internal_Due_Date.Value
End If
End Sub

Private Sub Form_Close()
'If Me.Text167.Value < Me.Text148.Value Then
'Me.Text167.Value = Me.Text148.Value
'Else
'Me.Text167.Value = Me.Dir_Internal_Due_Date.Value
'End If

Call DeletePDFfolder
  
End Sub

Private Sub Form_Current()
    If Me.NewRecord Then
        'Me.btnCopyPDFText.Enabled = False
        Me.ckBoxTextType.Enabled = False
        Me.Legal.DefaultValue = False
        Me.Text128.Enabled = False
        Me.Text130.Enabled = False
    
    End If
    'If Me.Priority = "EIR" Or Me.Priority = "CMP" Then
    '    Me.cmdEmail.Enabled = True
    'End If
    If Me!Legal = True Then
        Me.Text128.Enabled = True
        Me.Text130.Enabled = True
          
    Else
        Me.Text128.Enabled = False
        Me.Text130.Enabled = False
    End If
    
    If Me.Check138 = True Then
        Me.Text136.Enabled = True
        Me.Text148.Enabled = True
    Else
        Me.Text136.Enabled = False
        Me.Text148.Enabled = False
    End If
    
    If Me.Priority = "eir" Then
        Me.FAA_Closeout_Letter.Enabled = True
        Me.Closeout_Date.Enabled = True
    Else
        Me.FAA_Closeout_Letter.Enabled = False
        Me.Closeout_Date.Enabled = False
    End If
    
    'If Me.Priority = "EIR" Or Me.Priority = "cor" Or Me.Priority = "cmp" Then
    '   Me.cmdEmail.Enabled = True
                      
    'Else
    '    Me.cmdEmail.Enabled = False
    
    'End If
    
    
End Sub

Private Sub Form_Open(Cancel As Integer)
Call DeletePDFfolder

  If Me.Priority = "EIR" Or Me.Priority = "gen" Or Me.Priority = "aaip" Or Me.Priority = "ash" Or Me.Priority = "csop" Then
        'Me.cmdEmail.Enabled = True
        Me.Status.Enabled = True
        Me.Assigned_To.Enabled = True
        Me.Contact.Enabled = True
        Me.Due_Date.Enabled = True
        Me.Dir_Internal_Due_Date.Enabled = True
        Me.Text123.Enabled = True
        Me.Text125.Enabled = True
        Me.Completed_Date.Enabled = True
        'Me.cmdEmail.Enabled = False
        'Me.btnCopyPDFText.Enabled = False
    Else
        'Me.cmdEmail.Enabled = True 'False
        Me.Status.Enabled = False
        Me.Assigned_To.Enabled = True 'False
        Me.Contact.Enabled = False
        Me.Due_Date.Enabled = False
        Me.Dir_Internal_Due_Date.Enabled = False
        Me.Text123.Enabled = False
        Me.Text125.Enabled = False
        Me.Completed_Date.Enabled = True 'False
        'Me.cmdEmail.Enabled = False
        'Me.btnCopyPDFText.Enabled = False
    End If
    
   If Me.Attachments.AttachmentCount <= 0 Then
        'Me.cmdEmail.Enabled = False
        Me.btnCopyPDFText.Enabled = False
    Else
        Me.cmdEmail.Enabled = True
        Me.btnCopyPDFText.Enabled = True
    End If
    
   ' If Me.Check138 = True And Me.ExtenDirDa <> "" Then
    '    Me.Text160.Value = Me.ExtenDirDa
    'Else
     '   Me.Text160.Value = Me.InitDirRespRec
   ' End If
    
   ' If Me.Check138 = False Then
    '    Me.Text160.Value = Me.InitDirRespRec
    'End If
    If Me.Check189 = True Then
    Me.Text193.Enabled = True
    End If
    If Me.Check189 = False Then
    Me.Text193.Enabled = False
    End If

    If Me.Check191 = True Then
    Me.Text195.Enabled = True
    End If
    If Me.Check191 = False Then
    Me.Text195.Enabled = False
    End If

End Sub

Private Sub Legal_Click()
    If Me!Legal = True Then
        Me.Text128.Enabled = True
        Me.Text130.Enabled = True
          
    Else
        Me.Text128.Enabled = False
        Me.Text130.Enabled = False
    End If
End Sub

Private Sub priority_AfterUpdate()
    If IsNull([due date]) And [Priority] = "eir" Then
        [due date] = [Start Date] + 10
        [InitDirRespRec] = [Start Date] + 8
    End If
    If IsNull([due date]) And [Priority] = "enf" Then
        [due date] = [Start Date] + 10
        [InitDirRespRec] = [Start Date] + 8
    End If
    If IsNull([due date]) And [Priority] = "gen" Then
        [due date] = [Start Date] + 20
        [InitDirRespRec] = [Start Date] + 18
    End If
    If IsNull([due date]) And [Priority] = "aaip" Then
        [due date] = [Start Date] + 30
        [InitDirRespRec] = [Start Date] + 28
    End If
    If IsNull([due date]) And [Priority] = "ash" Then
        [due date] = [Start Date] + 30
        [InitDirRespRec] = [Start Date] + 28
    End If
    If IsNull([due date]) And [Priority] = "sa" Then
        [due date] = [Start Date] + 30
        [InitDirRespRec] = [Start Date] + 28
    End If
    If IsNull([due date]) And [Priority] = "ca" Then
        [due date] = [Start Date] + 30
        [InitDirRespRec] = [Start Date] + 28
    End If
    If Me.Priority = "eir" Then
        Me.FTA_Closeout_Letter.Enabled = True
        Me.Closeout_Date.Enabled = True
    Else
        Me.FTA_Closeout_Letter.Enabled = True 'False
        Me.Closeout_Date.Enabled = True 'False
    End If
    
    'If Me.Priority = "EIR" Or Me.Priority = "cor" Or Me.Priority = "cmp" Then
    '    Me.cmdEmail.Enabled = True
    'Else
    '    Me.cmdEmail.Enabled = False
    'End If
    
    If Me.Priority = "EIR" Or Me.Priority = "gen" Or Me.Priority = "aaip" Or Me.Priority = "csop" Or Me.Priority = "opr" Or Me.Priority = "cce" Or Me.Priority = "Cert. Ltr." Or Me.Priority = "ash" Or Me.Priority = "sa" Or Me.Priority = "enf" Or Me.Priority = "ca" Then
        'Me.cmdEmail.Enabled = True
        Me.Status.Enabled = True
        Me.Assigned_To.Enabled = True
        Me.Contact.Enabled = True
        Me.Due_Date.Enabled = True
        Me.Dir_Internal_Due_Date.Enabled = True
        Me.Text123.Enabled = True
        Me.Text125.Enabled = True
        Me.Completed_Date.Enabled = True
                
    Else
        'Me.cmdEmail.Enabled = True
        Me.Status.Enabled = False
        Me.Assigned_To.Enabled = True 'False
        Me.Contact.Enabled = True 'False
        Me.Due_Date.Enabled = True 'False
        Me.Dir_Internal_Due_Date.Enabled = True 'False
        Me.Text123.Enabled = True 'False
        Me.Text125.Enabled = True 'False
        Me.Completed_Date.Enabled = True 'False
        Me.Due_Date = Null
        Me.InitDirRespRec = Null
    End If
    
      If Me.Attachments.AttachmentCount <= 0 Then
        'Me.cmdEmail.Enabled = False
        Me.btnCopyPDFText.Enabled = False
    Else
        Me.cmdEmail.Enabled = True
        Me.btnCopyPDFText.Enabled = True
    End If
Me.Due_Date.Requery
Me.Dir_Internal_Due_Date.Requery


'Me.Refresh



'If([Priority]="eir",[Start Date]+10,IIf([Priority]="cor",[Start Date]+30,IIf([Priority]="cmp",[Start Date]+30,"")))
End Sub

Private Sub Priority_BeforeUpdate(Cancel As Integer)
    If Me.Priority = "EIR" Or Me.Priority = "gen" Or Me.Priority = "aaip" Or Me.Priority = "ash" Then
        Me.cmdEmail.Enabled = True
    Else
        'Me.cmdEmail.Enabled = False
    End If
    
End Sub

Private Sub Priority_DblClick(Cancel As Integer)
If [Priority] = "eir" Then
    [due date] = [Start Date] + 10
     [InitDirRespRec] = [Start Date] + 8
End If
If [Priority] = "enf" Then
    [due date] = [Start Date] + 10
     [InitDirRespRec] = [Start Date] + 8
End If
If [Priority] = "gen" Then
    [due date] = [Start Date] + 20
     [InitDirRespRec] = [Start Date] + 18
End If
If [Priority] = "aaip" Then
    [due date] = [Start Date] + 30
     [InitDirRespRec] = [Start Date] + 28
End If
If [Priority] = "ash" Then
    [due date] = [Start Date] + 30
     [InitDirRespRec] = [Start Date] + 28
End If
If [Priority] = "sa" Then
    [due date] = [Start Date] + 30
     [InitDirRespRec] = [Start Date] + 28
End If
If [Priority] = "ca" Then
    [due date] = [Start Date] + 30
     [InitDirRespRec] = [Start Date] + 28
End If
Me.Due_Date.Requery
Me.Dir_Internal_Due_Date.Requery
End Sub

Private Sub Text123_GotFocus()
If Me.Text167.Value < Me.Text148.Value Then
Me.Text167.Value = Me.Text148.Value
Else
Me.Text167.Value = Me.Dir_Internal_Due_Date.Value
End If
End Sub

Private Sub Text136_AfterUpdate()
[ExtenDirDa] = [ExtenDueDate] - 2

Me.Refresh

If Me.Text167.Value < Me.Text148.Value Then
Me.Text167.Value = Me.Text148.Value
Else
Me.Text167.Value = Me.Dir_Internal_Due_Date.Value
End If
End Sub

'Private Sub Text123_AfterUpdate()
'    If Len(Me!Text123) > 0 Then
'        DoCmd.RunCommand acCmdSpelling
'            Else
'        Exit Sub
'    End If
'End Sub

Private Sub Text148_AfterUpdate()


End Sub

Private Sub Text167_AfterUpdate()
[Text179] = [Text167] + 2
End Sub




Private Sub Text187_Change()

Me.Text197.Requery
End Sub

'MsgBox Me![Text187]
'End Sub
Private Sub Text197_GotFocus()
Me.Refresh
End Sub

Open in new window

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial