Weird Function Behavoir : Automated vs Manual

Question

Hi Folks -

I have the following function that's part of a nightly routine.  I have a batch script which calls an Ms Access Macro which then calls this Function.  The function just updates a SharePoint List, nothing too fancy.  It works great; however sometimes it fails which is expected if someone adds a value to the source data but not added to the Choice list in SharePoint, but that's not the issue. 

If it fails while I'm running it manually, the Function exits, distributes an email letting the team knows it failed and that's it, which is the expected behavior.  However, if it fails when executed by the macro (in the overnight routine) it just hangs.  An email is never sent out. I then need to kill the MSACCESS.exe and rerun manually to get the error to produce.

Does anyone know why? Could it be due to the way I have setup my Function?

Thank you!

Function Update_rdTarget()
On Error Resume Next
    
    Dim dbs As DAO.Database
    Dim sRS As DAO.Recordset
    Dim tRS As DAO.Recordset
    Dim tRSMV As DAO.Recordset
    Dim fld As DAO.Field2
    
    Dim sTable As String
    Dim tTable As String
       
    Dim tgtStr, srcStr As String
    Dim vStr() As String
    Dim tFlds, sFlds, vCriteria As String
    Dim tFld() As String
    Dim sFld() As String
        
    Dim i, z As Integer
    Dim strMask As String
    Dim strFunctName As String
    Dim strTimeDiff As String
    Dim strStartTime As Date
    Dim strEndTime As Date
    Dim strResult As String
    Dim strProcError As String
        
    Set ws = DBEngine.Workspaces(0)
    Set dbs = ws.Databases(0)
    
    strFunctName = "Update_rdTarget": strStartTime = Format(Now, "mm/dd/yyyy hh:mm:ss")
    
    On Error GoTo Proc_Err
    
    'Start a transaction to ensure all updates are run or rolled back
    ws.BeginTrans: strTFlag = 1
    
    strMask = "PFR*"
    sTable = "MDM_Project_Portfolio_Reference"
    tTable = "rdTarget"
    strNameSub = "TargetID"
    
    tFlds = strNameSub & ",[TargetAlias],[Termination_Reason],[Termination_Date],[Portfolio_Status],[Modality_Detail],[Target_Short_Name],[Target_Long_Name],[Business_Owner],[Mechanism],[Lead_Backup],[Lead_Backup_Compound],[Indication],[Alternate_Name],[IP_Owner],[PartnershipID],[PartnershipAlias]"
    sFlds = "Name,[Alias],[Termination_Reason],[Termination_Date],[Portfolio Status],[Modality_Detail],[Target_Short_Name],[Target Long Name],[Business_Owner],[Mechanism],[Lead_Backup_Indicator],[Lead_Backup_Asset_Compound],[Indication],[Alternate_Name],[IP Owner],[Partnership_Name_Link],[Partnership_Alias_Link]"
    
    tFld = Split(tFlds, ",")
    sFld = Split(sFlds, ",")
       
    strFldsQry = sTable & Replace(sFlds, ",", ", " & "[" & sTable & "].")
    strFldsQry = Replace(strFldsQry, sTable & "Name", "[" & sTable & "]" & "." & "[" & "Name" & "]")
    
    strStep = "Step 1: Add New Data Elements"
    strSQL = "" & _
            "INSERT INTO [" & tTable & "] (" & _
                tFlds & ",RequestStatus" & _
            " )" & _
            " SELECT" & _
                strFldsQry & _
                " ,'Published' As [RequestStatus]" & _
            " FROM [" & sTable & "]" & _
            "LEFT JOIN [" & tTable & "] ON [" & tTable & "].[" & strNameSub & "] = [" & sTable & "].[Name]" & _
            " WHERE [" & sTable & "].[Name] LIKE '*" & strMask & "*'" & _
                " AND [" & tTable & "].[" & strNameSub & "] IS NULL;"
    dbs.Execute strSQL, dbFailOnError
    
    'Clear Variables
    strStep = "": srcStr = "": tgtStr = ""

    'Open a table-type Recordset
    Set sRS = dbs.OpenRecordset("Select * from [" & sTable & "] where [Name] like """ & strMask & """", dbOpenDynaset)
    Set tRS = dbs.OpenRecordset("SELECT * FROM [" & tTable & "] WHERE [RequestStatus] = ""Published""", dbOpenDynaset)
    
    Do Until tRS.EOF
    
        srcStr = "": tgtStr = ""
        
            vCriteria = "Name = '" & tRS.Fields(strNameSub).value & "'"
            sRS.MoveFirst
            sRS.FindFirst vCriteria
            
            If Not sRS.NoMatch Then
            
                'Do Standard field mapping property updates
                For i = 0 To UBound(tFld)
                            
                    'Set fld to check .IsComplex property
                    Set fld = tRS(tFld(i))
                    
                    strStep = "Step 2: Update Data Element Attributes" & vbNewLine & vbNewLine & _
                              "Data Element - " & Nz(tRS.Fields(strNameSub).value, "") & vbNewLine & _
                              "Source Field - " & Nz(sFld(i), "") & vbNewLine & _
                              "Source Value - " & Nz(sRS.Fields(sFld(i)).value, "") & vbNewLine & _
                              "Target Field - " & Nz(tFld(i), "") & vbNewLine & _
                              "Target Value - " & Nz(tRS.Fields(tFld(i)).value, "")
                              
                    'Ignore MVF Attributes
                    If Not fld.IsComplex Then
                        If Nz(tRS.Fields(tFld(i)).value, "foo") <> Nz(sRS.Fields(sFld(i)).value, "foo") Then
                            tRS.Edit
                            tRS.Fields(tFld(i)).value = sRS.Fields(sFld(i)).value
                            tRS.Update
                        End If
                    Else
                        'Process MVF Attributes
                        tRS.Edit
                        Set tRSMV = tRS(tFld(i)).value
                        
                        tgtStr = ""
                        Erase vStr
                         
                        'Concatenate the multiple values in a single string
                        Do Until tRSMV.EOF
                            tRSMV.MoveFirst
                                Do Until tRSMV.EOF
                                    tgtStr = tgtStr + tRSMV!value.value + ","
                                    tRSMV.MoveNext
                                Loop
                        Loop
                        If Not tgtStr = "" Then
                            tgtStr = Mid(tgtStr, 1, Len(tgtStr) - 1)
                            tRSMV.MoveFirst
                        End If
        
                        'Compare the concatenated strings
                        If Nz(sRS.Fields(sFld(i)).value, "") <> tgtStr Then
                            Do Until tRSMV.EOF
                                tRSMV.MoveFirst
                                    Do Until tRSMV.EOF
                                        tRSMV.Delete
                                        tRSMV.MoveNext
                                    Loop
                            Loop
                            
                            If Nz(sRS.Fields(sFld(i)).value, "") <> "" Then
                                vStr = Split(sRS.Fields(sFld(i)).value, ",")
        
                                For z = 0 To UBound(vStr)
                                   tRSMV.AddNew
                                   tRSMV.Fields(0).value = vStr(z)
                                   tRSMV.Update
                                Next
                            End If
                        End If
                        tRS.Update
                     End If
                Next
                
                If tRS.Fields("RequestStatus").value <> "Published" Then
                    tRS.Edit
                    tRS.Fields("RequestStatus").value = "Published"
                    tRS.Update
                End If
                
            End If
        
        tRS.MoveNext
    Loop
    
    'commit all changes
    ws.CommitTrans: strTFlag = 0
    
    
    Set sRS = Nothing
    Set tRS = Nothing
    Set tRSMV = Nothing
 
Proc_Exit:

    '::-- Update Start & End Times --::'
    If strResult = "" Then strResult = "Success"
    strEndTime = Format(Now, "mm/dd/yyyy hh:mm:ss")
    strTimeDiff = strEndTime - strStartTime
    Call ADD_RUN_TIMES(strFunctName, strStartTime, strEndTime, _
                       Hour(strTimeDiff) & " hours " & Minute(strTimeDiff) & " minutes " & Second(strTimeDiff) & " seconds", _
                       strResult, _
                       strProcError _
                       )
       
    Set ws = Nothing
    Set dbs = Nothing
    Exit Function

Proc_Err:

    strResult = "Failed"
    strProcError = Err.Description
    If Len(strStep) > 0 Then
        EmailStep = strStep & vbNewLine & vbNewLine
    Else
        EmailStep = ""
    End If
    
    strSubject = "WARNING : Function '" & strFunctName & "' Failed"
    strBody = strSubject & vbNewLine & vbNewLine & _
              EmailStep & _
              "Profile : " & CurrentUser() & vbNewLine & vbNewLine & _
              "VB Module : " & Application.VBE.ActiveCodePane.CodeModule.name & vbNewLine & vbNewLine & _
              "VB Error : " & Err.Description
    strTo = "[e-mail]"
    Call MDM_Routines.Email_Utility(strSubject, strBody, strTo, "", "")
    
    If strTFlag = 1 Then ws.Rollback
    
    Resume Proc_Exit
    
End Function

Answer 1

Is your nightly routine run as a Windows Scheduled Task?  Perhaps the user account you're using isn't able to send emails due to insufficient permissions, no Exchange account, etc.

-Bruce

Answer 2

cdtakacs1 –

Since you ask ~

1. When variables are declared like this

    Dim tgtStr, srcStr As String

the type of srcStr  _is_ String but tgtStr _is_ Variant.

An improvement is

    Dim tgtStr As String, srcStr As String

2. Generally speaking, 208 lines is too long to test the software easily.

a. One suggestion about finding the problem is to put the error processing code in a separate function and test it all by itself with a single driver.

b. What does the mail function require in way of where it is being called from? Logged in user? ?

---

peter n roth - http://PNR1.com, Maybe some useful stuff

Answer 3

Hi All -

Thank you very much for your info. I wanted to provide some additional detail.

I do have it scheduled using Windows Task Scheduler.  Furthermore, when executing manually, the email works fine. For some clarity, here is my email sub:

Sub Email_Utility(strSubject, strBody, strTo, strCC, strAttach)
    
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtprelay.client.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With
        
        With iMsg
            Set .Configuration = iConf
            .To = strTo
            .CC = strCC
            .BCC = ""
            .FROM = "[e-mail]"
            .Subject = strSubject
            .TextBody = strBody
        End With
        
        If Len(strAttach) > 0 Then iMsg.AddAttachment strAttach
        iMsg.send

    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub

Could Windows Task Scheduler user be conflicting with the email utility? It's open relay so I wouldn't think so

Answer 4

Do you mean that the email works fine when you interactively run this sub from within Access or do you mean that it works fine when you manually run the scheduled task?  Does your scheduled task use your user account or another?  Does the history tab of the scheduled task tell you anything (you may have to enable the history in the Actions section of the task scheduler)?  It's only a guess but it may be that the account you are using to run your scheduled task is not authenticated on your smtp server.

-Bruce

Answer 5

Hi cdtakacs1,

I don't have the time to look through of your code. I'm also not sure why it didn't throw an error. You might also need to declare "Option Base 1" or "0" if required.

Dim vStr() As String
Dim tFld() As String
Dim sFld() As String

These 3 Arrays are likely to cause issues. You code should be something like this....

Dim tFlds As Variant

Dim sFlds As Variant

tFlds = Array(strNameSub ,"[TargetAlias]","[Termination_Reason]",........)

sFlds = Array("Name,[Alias]","[Termination_Reason]",.......)

Debug.Print tFlds(1)

Debug.Print sFlds(1)

Please look at this MS document on how to use arrays. MS VB Array

HTH

Answer 6

Hi Team -

I figured out my issue.  I have these function running within a Macro and in that Macro I have a Set Warnings : No.  Therefore what was happening was if there was an error, it was failing on this line:

"VB Module : " & Application.VBE.ActiveCodePane.CodeModule.Name & vbNewLine & vbNewLine & _

So i had to activate the modules first, I created a new function to Activate all my modules, works fine now!

Function Activate_Modules()
    VBE.ActiveVBProject.VBComponents("MDM_Routines").Activate
    VBE.ActiveVBProject.VBComponents("Process_MDM_Requests").Activate
    VBE.ActiveVBProject.VBComponents("Process_MDM_Requests_Auto").Activate
    VBE.ActiveVBProject.VBComponents("Update_SharePoint_Reference_Lists").Activate
    VBE.ActiveVBProject.VBComponents("Update_SharePoint_Request_Lists").Activate

End Function

Thanks for all the help!