Pacifc Tech - Workflow Step Macro to check daily PO approval limits

[johnhugh]

Hi, is there someone here who has written a workflow step macro for Purchasing Workflow 6 that runs sucessfully?

I have a macro I use to check whether the user is within his daily PO approval limit.
It runs ok, but also fails too often. I can't actually tell why it fails but reckon the 2 main reasons are:
1. The user can close Accapc whilst the macro is still running. Contacted Pacific Tech on that but no reply yet.
2. There might be an issue when multiple requisitions are approved at the same time because they all run in seperate threads and are not worked through in a sequentiell order.

Would appreciate some feedback/advise on my code also.

Public strUserID, strDate As String
Public dblPORemaining As Double
Public CountRQNs As Integer
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub MainSub()
Dim strWorkflow, strRQNNumber As String
Dim intWorkflowType, intFunction As Integer
Dim dblSequence, dblRQNValue, dblPORemaining As Double

dblPORemaining = 0
dblRQNValue = 0

On Error GoTo ACCPACErrorHandler

UserForm1.Show vbModeless

Dim mDBLinkCmpRW As AccpacCOMAPI.AccpacDBLink
Set mDBLinkCmpRW = OpenDBLink(DBLINK_COMPANY, DBLINK_FLG_READWRITE)

Dim PTMACLOG As AccpacCOMAPI.AccpacView
mDBLinkCmpRW.OpenView "PT0036", PTMACLOG

Dim PTFNCTN As AccpacCOMAPI.AccpacView
mDBLinkCmpRW.OpenView "PT0900", PTFNCTN

Dim PTPRH As AccpacCOMAPI.AccpacView
mDBLinkCmpRW.OpenView "PT0040", PTPRH

strUserID = mDBLinkCmpRW.Session.UserID
strDate = Format(Now, "dd/MM/yyyy")
strDate = Right(strDate, 4) & Mid(strDate, 4, 2) & Left(strDate, 2)

' force other RQNs to wait for approval
' work through every RQN individually to check updated PO limit after every RQN has been approved
Do
    Call CheckMultipleApprovals
    If CountRQNs <> 0 Then
        Sleep 5000 'sleep 5 seconds
    End If
Loop While CountRQNs <> 0

PTMACLOG.RecordClear
PTMACLOG.Browse "USERID=""" & strUserID & """ AND LOGSTATUS=1", True

If PTMACLOG.Fetch Then

    strWorkflow = PTMACLOG.Fields.FieldByName("WORKFLOW").Value
    strRQNNumber = PTMACLOG.Fields.FieldByName("DOCNUMBER").Value
    intWorkflowType = PTMACLOG.Fields.FieldByName("WRKFLWTYPE").Value
    dblSequence = PTMACLOG.Fields.FieldByName("SEQUENCE").Value
    PTMACLOG.Fields.FieldByName("LOGSTATUS").PutWithoutVerification 2
    PTMACLOG.Update

    ' macro code here
    
    'find RQN Number
    PTPRH.RecordClear
    PTPRH.Browse "RQNNUMBER=" & strRQNNumber & "", True
    If PTPRH.Fetch Then
        dblRQNValue = PTPRH.Fields.FieldByName("HCTOTRQVAL").Value
    End If
    
    'get current remaining PO limit
    Call GetPOLimit(dblPORemaining)
       
    ' check whether Daily limit has been reached
    If dblPORemaining >= 0 Then
        intFunction = 25
        dblPORemaining = dblPORemaining - dblRQNValue
    Else
        intFunction = 26
        Call MsgBox("Insufficient PO Approval Limit. PO Approval Declined for " & strRQNNumber & ".", vbOKOnly + vbSystemModal + vbMsgBoxSetForeground)
    End If
        
    
    ' macro result status: succeeded/failed
    ' process RQN for completion
    PTFNCTN.RecordClear
    PTFNCTN.Fields.FieldByName("FUNCTION").PutWithoutVerification intFunction    ' 25 success / 26 for failure
    PTFNCTN.Fields.FieldByName("WORKFLOW").PutWithoutVerification strWorkflow
    PTFNCTN.Fields.FieldByName("TYPE").PutWithoutVerification intWorkflowType
    PTFNCTN.Fields.FieldByName("KEY").PutWithoutVerification dblSequence

    PTFNCTN.Process
  
End If

Set mDBLinkCmpRW = Nothing

Unload UserForm1

Exit Sub

ACCPACErrorHandler:
  Dim lCount As Long
  Dim lIndex As Long

  If Errors Is Nothing Then
       MsgBox Err.Description
  Else
      lCount = Errors.Count

      If lCount = 0 Then
          MsgBox Err.Description
      Else
          For lIndex = 0 To lCount - 1
              MsgBox Errors.Item(lIndex)
          Next
          Errors.Clear
      End If
      Resume Next

  End If

End Sub

Sub CheckMultipleApprovals()
Dim rsPTMACLOG As Recordset
Dim strSQL3 As String

'count number of RQNS beeing approved simultaneously
'value of all these RQNs is being checked, whether within PO approval limit
strSQL3 = "SELECT COUNT(DOCNUMBER) AS CountRQNS" _
            & " FROM PTMACLOG" _
            & " WHERE (USERID = '" + strUserID + "') AND (AUDTDATE = '" + strDate + "') AND (LOGSTATUS = 2)"

strCnn = "Provider=sqloledb;" & _
"Data Source=localhost;Initial Catalog=database;User Id= sa  ;Password=password; "
   
Set rsPTMACLOG = New ADODB.Recordset
rsPTMACLOG.CursorType = adOpenKeyset
rsPTMACLOG.LockType = adLockOptimistic
rsPTMACLOG.Open strSQL3, strCnn, , , adCmdText

If Not (rsPTMACLOG.EOF) Then
    rsPTMACLOG.MoveFirst
    Do
        CountRQNs = rsPTMACLOG!CountRQNs
        Exit Do
    rsPTMACLOG.MoveNext
    Loop While Not rsPTMACLOG.EOF
End If

Set rsPTMACLOG = Nothing
End Sub

Sub GetPOLimit(dblPORemaining As Double)
Dim rsPOPORH1 As Recordset
Dim strSQL1, strSQL2 As String

strSQL1 = "SELECT t.ApprovalDate, Approved, POLimit, POApprover, ROUND((POLimit - Approved),2) as PORemaining" _
            & " FROM" _
            & " (SELECT PTPRH.AUDTDATE as ApprovalDate,SUM(PTPRH.HCTOTRQVAL) AS Approved, PTLEV.[DESC] AS POLimit, PTPRH.AUDTUSER as POApprover" _
            & "         FROM PTPRH  AS PTPRH INNER JOIN" _
            & "             PTUSER AS PTUSER ON PTPRH.AUDTUSER = PTUSER.USERID INNER JOIN" _
            & "             PTLEV AS PTLEV ON PTUSER.AUTHLEVEL = PTLEV.AUTHLEVEL" _
            & "         WHERE  (PTPRH.STATUS >= 22 AND PTPRH.STATUS <=70) AND (PTPRH.AUDTUSER = '" + strUserID + "') AND  PTPRH.AUDTDATE = '" + strDate + "' AND (PTPRH.CNTCAPITEM =0)" _
            & "         GROUP BY PTPRH.AUDTDATE,PTLEV.[DESC] , PTPRH.AUDTUSER) AS t"

strCnn = "Provider=sqloledb;" & _
"Data Source=localhost;Initial Catalog=database;User Id= sa  ;Password=password; "
   
Set rsPOPORH1 = New ADODB.Recordset
rsPOPORH1.CursorType = adOpenKeyset
rsPOPORH1.LockType = adLockOptimistic
rsPOPORH1.Open strSQL1, strCnn, , , adCmdText
    
If Not (rsPOPORH1.EOF) Then
    rsPOPORH1.MoveFirst
    Do
       If Trim(rsPOPORH1!POApprover) = strUserID Then
            dblPORemaining = rsPOPORH1!PORemaining
            Exit Do
       End If
    rsPOPORH1.MoveNext
    Loop While Not rsPOPORH1.EOF
Else
    'if above SQL query returns no results, get PO limit of user if he has not purchased anything yet and still has full limit
    strSQL2 = "SELECT   PTLEV.[DESC] AS POLimit, PTUSER.USERID as POApprover" _
               & " FROM  PTUSER INNER JOIN PTLEV on PTLEV.AUTHLEVEL = PTUSER.AUTHLEVEL" _
               & " WHERE (PTUSER.USERID = '" + strUserID + "')"
    
    Set rsPOPORH1 = New ADODB.Recordset
    rsPOPORH1.CursorType = adOpenKeyset
    rsPOPORH1.LockType = adLockOptimistic
    rsPOPORH1.Open strSQL2, strCnn, , , adCmdText
    
    If Not (rsPOPORH1.EOF) Then
        rsPOPORH1.MoveFirst
        Do
        If Trim(rsPOPORH1!POApprover) = strUserID Then
            dblPORemaining = rsPOPORH1!POLimit
            Exit Do
        End If
        rsPOPORH1.MoveNext
        Loop While Not rsPOPORH1.EOF
    End If
End If

    Set rsPOPORH1 = Nothing
End Sub

 

[Jay Converse]

1. Is this an Accpac AVB macro? You shouldn't be able to close Accpac. With An EXE you can.
2. You're using ADODB, which bypasses business logic and unposted transactions. Use views.

 

[johnhugh]

Thanks tuba.
Yes. It's ab avb macro whcih continues even when closing Accpac - obviously failing then.
With my ADODB I'm only reading values, not writing. If you look at my SQL statements I don't think I would be able to do the same with views.

 

[Jay Converse]

1. I've never had an AVB macro that's run from the Accpac desktop continue running.
2. Just because it's reading doesn't mean it will necessarily work correctly. Open view records are uncommitted, hence the SQL data is not current.