I have a VBA macro (not an Excel macro) that is pulling data from one system and inserting into another that is failing.
Is there a way to write to a text file the data it is trying to insert? I want to see the state of the data before trying to insert.
What the code is supposed to do: Take returns from ERP and insert into Accpac/GL system. A custom macro was written to do this, however it will not pull in old returns. I believe it is because of the period being lock in Accpac, however I want to see where it would be referencing such data.
The mega macro:
Option Explicit
Private dsDate1 As AccpacDataSrc.AccpacCustomField
Private dsDate2 As AccpacDataSrc.AccpacCustomField
Private blnCancel As Boolean
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdReceipts_Click()
DoRecpts
'DoCSV
Print #2, "Interface ended" & Now
Close #2
Shell "Notepad.exe " & "ReceiptProcess" & Format(Date, "mmddyyyy") & ".txt"
End Sub
Private Sub DoRecpts()
blnCancel = False
'Dim vRCHead As AccpacView
'Dim vRCDet As AccpacView
'Dim vRCComm As AccpacView
'Dim vRCVend As AccpacView
'Dim vRCAddit As AccpacView
'Dim vRCFunct As AccpacView
'Dim vRCPO As AccpacView
'Dim vRCHeadO As AccpacView
'Dim vRCCost As AccpacView
'Dim vRCDetO As AccpacView
'Dim vRCVendO As AccpacView
'Dim vRCAdditO As AccpacView
'Dim vRCCostDist As AccpacView
'Dim vRCProrate As AccpacView
'Dim vRTHead As AccpacView
'Dim vRTDet As AccpacView
'Dim vRTComm As AccpacView
'Dim vRTFunct As AccpacView
'Dim vRTHeadO As AccpacView
'Dim vRTDetO As AccpacView
Dim vRTHead As AccpacCOMAPI.AccpacView
Dim vRTDet As AccpacCOMAPI.AccpacView
Dim vRTComm As AccpacCOMAPI.AccpacView
Dim vRTFunct As AccpacCOMAPI.AccpacView
Dim vRTHeadO As AccpacCOMAPI.AccpacView
Dim vRTDetO As AccpacCOMAPI.AccpacView
'new
Dim vRTLineLots As AccpacCOMAPI.AccpacView
Dim vRTLineSerials As AccpacCOMAPI.AccpacView
Dim vVend As AccpacCOMAPI.AccpacView
Dim rsRecpt As New ADODB.Recordset
Dim strSQL As String
Dim strErrLog As String
Dim blnErr As Boolean
Dim strCLast As String
Dim strCCurr As String
Dim strTLast As String
Dim strTCurr As String
Dim blnReturn As Boolean
Dim blnHeaderr As Boolean
Dim lngCount As Long
Dim vLast As String
Dim vCurr As String
Dim blnBadVend As Boolean
Dim start As Variant
Dim blnEOF As Boolean
blnEOF = False
'dbCmp.OpenView "PO0700", vRCHead
'dbCmp.OpenView "PO0710", vRCDet
'dbCmp.OpenView "PO0695", vRCComm
'dbCmp.OpenView "PO0718", vRCVend
'dbCmp.OpenView "PO0714", vRCAddit
'dbCmp.OpenView "PO0699", vRCFunct
'dbCmp.OpenView "PO0705", vRCPO
'dbCmp.OpenView "PO0703", vRCHeadO
'dbCmp.OpenView "PO0696", vRCCost
'dbCmp.OpenView "PO0717", vRCDetO
'dbCmp.OpenView "PO0721", vRCVendO
'dbCmp.OpenView "PO0719", vRCAdditO
'dbCmp.OpenView "PO0697", vRCCostDist
'dbCmp.OpenView "PO0704", vRCProrate
dbCmp.OpenView "PO0731", vRTHead
dbCmp.OpenView "PO0735", vRTDet
dbCmp.OpenView "PO0729", vRTComm
dbCmp.OpenView "PO0730", vRTFunct
dbCmp.OpenView "PO0738", vRTHeadO
dbCmp.OpenView "PO0739", vRTDetO
dbCmp.OpenView "PO0799", vRTLineLots
dbCmp.OpenView "PO0790", vRTLineSerials
dbCmp.OpenView "AP0015", vVend
'vRCHead.Compose Array(vRCComm, vRCDet, vRCVend, _
' vRCAddit, vRCFunct, vRCPO, vRCHeadO, vRCCost)
'
'vRCDet.Compose Array(vRCHead, vRCComm, vRCFunct, _
' Nothing, Nothing, vRCDetO)
'
'
'vRCComm.Compose Array(vRCHead, vRCDet)
'vRCVend.Compose Array(vRCHead, vRCAddit, vRCFunct, vRCVendO)
'
'vRCAddit.Compose Array(vRCVend, vRCFunct, vRCHead, Nothing, _
' Nothing, vRCCost)
'
'vRCFunct.Compose Array(vRCHead, vRCComm, vRCDet, vRCAddit, _
' vRCVend, vRCPO, vRCCost)
'
'vRCPO.Compose Array(vRCHead, vRCFunct)
'vRCHeadO.Compose Array(vRCHead)
'vRCCost.Compose Array(vRCAddit, vRCVend, vRCHead, vRCFunct, vRCCostDist)
'vRCDetO.Compose Array(vRCDet)
'vRCVendO.Compose Array(vRCVend)
'vRCAdditO.Compose Array(vRCAddit)
'vRCCostDist.Compose Array(Nothing, vRCCost, vRCAddit)
'vRCProrate.Compose Array(vRCCost, vRCDet)
'vRTHead.Compose Array(vRTComm, vRTDet, vRTFunct, vRTHeadO)
'vRTDet.Compose Array(vRTHead, vRTComm, vRTFunct, _
' Nothing, Nothing, vRTDetO)
'vRTComm.Compose Array(vRTHead, vRTDet)
'vRTFunct.Compose Array(vRTHead, vRTComm, vRTDet)
'vRTHeadO.Compose Array(vRTHead)
'vRTDetO.Compose Array(vRTDet)
vRTHead.Compose Array(vRTComm, vRTDet, vRTFunct, vRTHeadO)
vRTDet.Compose Array(vRTHead, vRTComm, vRTFunct, Nothing, Nothing, vRTDetO, vRTLineLots, vRTLineSerials)
vRTComm.Compose Array(vRTHead, vRTDet)
vRTFunct.Compose Array(vRTHead, vRTComm, vRTDet, vRTLineLots, vRTLineSerials)
vRTHeadO.Compose Array(vRTHead)
vRTDetO.Compose Array(vRTDet)
vRTLineLots.Compose Array(vRTDet, Nothing, Nothing)
vRTLineSerials.Compose Array(vRTDet, Nothing, Nothing)
On Error GoTo RecErr
strErrLog = "ReturnErrors.log"
' To filter zero dollar receipts, field rec_header.rh_rtd_cost<>0
strSQL = "SELECT rec_header.*, rec_detail.*, vendors.*, inv.* " & _
"FROM rec_header " & _
"INNER JOIN rec_detail ON rec_header.rh_id = rec_detail.rd_id " & _
"INNER JOIN vendors ON rec_header.rh_vendor = vendors.ve_id " & _
"INNER JOIN inv ON rec_detail.rd_id3 = inv.inv_id3 " & _
"WHERE rec_detail.rd_pst_cou_dtm >= '" & Format(feDateStrt, "yyyy-mm-dd hh:mm:ss") & _
"' and rec_detail.rd_pst_cou_dtm < '" & _
Format(DateAdd("D", 1, feDateEnd), "yyyy-mm-dd hh:mm:ss") & _
"' and rec_header.rh_status = 'PST'"
rsRecpt.Open strSQL, Conn, adOpenDynamic, adLockOptimistic, adCmdText
With rsRecpt
Do Until .EOF
vCurr = .Fields("ve_acct")
If vCurr <> vLast Then
blnBadVend = False
vVend.Init
vVend.Browse "VENDORID =" & .Fields("ve_acct"), True
If vVend.Fetch = False Then GoTo NoVend
End If
If .Fields("rd_total") < 0 Then
' strCCurr = .Fields("rh_id")
'
' If strCCurr <> strCLast Then
' blnReturn = False
' If strCLast <> "" Then
' If blnBadVend = True Then GoTo NextDetail
' vRCHead.Insert
' If strCLast <> "" Then Print #2, "Receipt " & strCLast & " entered."
' If blnHeaderr = False Then lngCount = lngCount + 1
' blnHeaderr = False
' DoEvents
' If blnCancel = True Then GoTo FinishUp
' End If
'RedoRCHead:
' vRCHead.RecordGenerate False
' lblInfo.Caption = "Doing receipt no: " & .Fields("rh_id") & "..."
' Me.Repaint
'
' vRCHead.Fields("VDCODE") = .Fields("ve_acct")
' vRCHead.Fields("RCPNUMBER") = CStr(.Fields("rh_id"))
' vRCHead.Fields("DESCRIPTIO") = "Receiver import from Apropos"
' vRCHead.Fields("REFERENCE") = .Fields("rh_po_id")
' vRCHead.Fields("DATE") = .Fields("rh_arrival_date")
'
' vRCHeadO.Fields("OPTFIELD").PutWithoutVerification "PO"
' vRCHeadO.Fields("VALUE") = .Fields("rh_po_id")
' vRCHeadO.Insert
' End If
' vRCDet.RecordGenerate False
' vRCDet.Fields("ITEMNO") = "INV"
' vRCDet.Fields("ITEMDESC") = .Fields("inv_id3") & " - " & .Fields("inv_desc")
' vRCDet.Fields("RQRECEIVED") = .Fields("rd_total")
' vRCDet.Fields("UNITCOST") = Round(.Fields("rd_cost"), 2)
' If Not IsNull(.Fields("rh_spec_instr")) Then
' vRCComm.RecordGenerate False
' vRCComm.Fields("COMMENTTYP") = 1
' vRCComm.Fields("COMMENT") = .Fields("rh_spec_instr")
' vRCComm.Insert
' End If
'
' If Not IsNull(.Fields("rh_recv_instr")) Then
' vRCComm.RecordGenerate False
' vRCComm.Fields("COMMENTTYP") = 1
' vRCComm.Fields("COMMENT") = .Fields("rh_recv_instr")
' vRCComm.Insert
' End If
' vRCDet.Insert
' strCLast = strCCurr
' Else
strTCurr = .Fields("rh_id")
If strTCurr <> strTLast Then
blnReturn = True
If strTLast <> "" Then
vRTHead.Insert
If strTLast <> "" Then Print #2, "Return " & strTLast & " entered."
If blnHeaderr = False Then lngCount = lngCount + 1
blnHeaderr = False
If blnBadVend = True Then GoTo NextDetail
DoEvents
If blnCancel = True Then GoTo FinishUp
End If
RedoRtHead:
vRTHead.RecordGenerate False
lblInfo.Caption = "Doing return no: " & .Fields("rh_id") & "..."
Me.Repaint
vRTHead.Fields("VDCODE") = .Fields("ve_acct")
vRTHead.Fields("RETNUMBER") = CStr(.Fields("rh_id"))
vRTHead.Fields("DESCRIPTIO") = "Return import from Apropos"
vRTHead.Fields("REFERENCE") = .Fields("rh_po_id")
vRTHead.Fields("DATE") = .Fields("rh_arrival_date")
vRTHeadO.Fields("OPTFIELD").PutWithoutVerification "PO"
vRTHeadO.Fields("VALIFTEXT") = .Fields("rh_po_id")
vRTHeadO.Insert
End If
vRTDet.RecordGenerate False
vRTDet.Fields("ITEMNO") = "INV"
vRTDet.Fields("ITEMDESC") = .Fields("inv_id3") & " - " & .Fields("inv_desc")
vRTDet.Fields("RQRETURNED") = -.Fields("rd_total")
vRTDet.Fields("UNITCOST") = Round(.Fields("rd_cost"), 2)
If Not IsNull(.Fields("rh_spec_instr")) Then
vRTComm.RecordGenerate False
vRTComm.Fields("COMMENTTYP") = 1
vRTComm.Fields("COMMENT") = .Fields("rh_spec_instr")
vRTComm.Insert
End If
If Not IsNull(.Fields("rh_recv_instr")) Then
vRTComm.RecordGenerate False
vRTComm.Fields("COMMENTTYP") = 1
vRTComm.Fields("COMMENT") = .Fields("rh_recv_instr")
vRTComm.Insert
End If
vRTDet.Insert
strTLast = strTCurr
End If
NextDetail:
If .BOF Or .EOF Then Exit Do
.MoveNext
vLast = vCurr
Loop
' If blnReturn Then vRTHead.Insert Else vRCHead.Insert
If strTCurr <> "" And blnEOF = False Then
blnEOF = True
vRTHead.Insert
End If
.Close
End With
FinishUp:
'Set rsRecpt = Nothing
'Set vRTHead = Nothing
'Set vRTDet = Nothing
'Set vRTComm = Nothing
'Set vRTFunct = Nothing
'Set vRCHead = Nothing
'Set vRCDet = Nothing
'Set vRCAddit = Nothing
'Set vRCComm = Nothing
'Set vRCFunct = Nothing
MsgBox lngCount & " returns have been entered into ACCPAC", vbOKOnly + vbInformation, "Finished"
If blnErr = True Then Shell "Notepad.exe " & strErrLog
lblInfo.Caption = ""
Me.Repaint
Exit Sub
NoVend:
If vCurr <> vLast Then
blnBadVend = True
If blnErr = False Then
Open strErrLog For Output As #1
blnErr = True
Print #1, "The following returns were not entered for the reasons indicated."
Else
Open strErrLog For Append As #1
End If
If rsRecpt.Fields("rd_total") > 0 Then
Print #1, "The vendor " & rsRecpt.Fields("ve_acct") & " does not exist so " & strCLast & " was not added."
Else
Print #1, "The vendor " & rsRecpt.Fields("ve_acct") & " does not exist so " & strTLast & " was not added."
End If
Close #1
End If
GoTo NextDetail
RecErr:
If blnErr = False Then
Open strErrLog For Output As #1
blnErr = True
Print #1, "The following returns were not entered for the reasons indicated."
Else
Open strErrLog For Append As #1
End If
If AccpacSession.Errors.Count > 0 Then
If InStr(1, AccpacSession.Errors(0), "already exists") > 0 Then
Print #1, "The return " & strTLast & _
" was not added because it already exists in ACCPAC"
vRTHead.Cancel
strTLast = ""
Close #1
AccpacSession.Errors.Clear
Err.Clear
blnHeaderr = True
Resume Next
End If
If InStr(1, AccpacSession.Errors(0), "compute tax") > 0 Then
Print #1, "The return " & rsRecpt.Fields("rh_id") & _
" was not added because cannot compute tax."
vRTHead.Cancel
strTLast = ""
Close #1
AccpacSession.Errors.Clear
Err.Clear
blnHeaderr = True
Resume NextDetail
End If
Else
Print #1, Err.Description
End If
Close #1
AccpacSession.Errors.Clear
Err.Clear
Resume NextDetail
End Sub
Private Sub feDateEnd_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If feDateStrt > feDateEnd Then
MsgBox "The ending date must be greater than the beginning date"
feDateEnd = feDateStrt
End If
End Sub
Private Sub UserForm_Initialize()
Set dsDate1 = New AccpacDataSrc.AccpacCustomField
Set dsDate2 = New AccpacDataSrc.AccpacCustomField
dsDate1.Init FLD_DATE, FLD_EDITABLE + FLD_ENABLED
dsDate2.Init FLD_DATE, FLD_EDITABLE + FLD_ENABLED
feDateStrt.AccpacField = dsDate1
feDateEnd.AccpacField = dsDate2
feDateStrt = DateAdd("D", -7, Date)
feDateEnd = Date
End Sub
Private Sub DoCSV()
Dim rsRecpt As New ADODB.Recordset
Dim vVend As AccpacView
Dim strSQL As String
Dim strErrLog As String
Dim blnErr As Boolean
Dim strCLast As String
Dim strCCurr As String
Dim strTLast As String
Dim strTCurr As String
Dim blnReturn As Boolean
Dim blnHeaderr As Boolean
Dim lngCCount As Long
Dim lngTCount As Long
Dim lngDetail As Long
Dim lngComment As Long
Dim vLast As String
Dim vCurr As String
Dim blnBadVend As Boolean
Dim start As Variant
Dim lngVendErr As Long
dbCmp.OpenView "AP0015", vVend
strSQL = "SELECT rec_header.*, rec_detail.*, vendors.*, inv.* " & _
"FROM rec_header " & _
"INNER JOIN rec_detail ON rec_header.rh_id = rec_detail.rd_id " & _
"INNER JOIN vendors ON rec_header.rh_vendor = vendors.ve_id " & _
"INNER JOIN inv ON rec_detail.rd_id3 = inv.inv_id3 " & _
"WHERE rec_detail.rd_pst_cou_dtm >= '" & Format(feDateStrt, "yyyy-mm-dd hh:mm:ss") & _
"' and rec_detail.rd_pst_cou_dtm < '" & Format(DateAdd("D", 1, feDateEnd), "yyyy-mm-dd hh:mm:ss") & _
"' and rec_header.rh_status = 'PST'"
rsRecpt.Open strSQL, Conn, adOpenDynamic, adLockOptimistic, adCmdText
Open AccpacSession.ProgramsPathOnServer & "Receipt Import.csv" For Output As #2
Open AccpacSession.ProgramsPathOnServer & "Return Import.csv" For Output As #3
CreateHeaderInfo ' Put the header line in the csv file.
With rsRecpt
Do Until .EOF
vCurr = .Fields("ve_acct")
If vCurr <> vLast Then ' Check to see if the vendor exists
blnBadVend = False
vVend.Init
vVend.Browse "VENDORID =" & .Fields("ve_acct"), True
If vVend.Fetch = False Then
lngVendErr = 1
GoTo VendErr
Else ' if the vendor is inactive or on hold.
If vVend.Fields("SWACTV") = 0 Then
lngVendErr = 2
GoTo VendErr
End If
If vVend.Fields("SWHOLD") = 1 Then
lngVendErr = 3
GoTo VendErr
End If
End If
End If
If .Fields("rd_total") > 0 Then ' if the amount is >0 it's a receipt.
strCCurr = .Fields("rh_id")
If strCCurr <> strCLast Then ' If the current receipt isn't the same as the last.
If blnHeaderr = False Then lngCCount = lngCCount + 1
blnHeaderr = False
' Write a header record.
Write #2, 1, lngCCount, Format(.Fields("rh_arrival_date"), "YYYYMMDD"), _
CStr(.Fields("rh_id")), .Fields("ve_acct"), "Receiver import from Apropos", _
.Fields("rh_po_id")
lngDetail = 0
lngComment = 0
lblInfo.Caption = "Doing receipt no: " & .Fields("rh_id") & "..."
Me.Repaint
' Write the optional field
Write #2, 7, lngCCount, "PO", .Fields("rh_po_id")
End If ' End of header writing
' Write the detail line
lngDetail = lngDetail + 100
Write #2, 2, lngCCount, lngDetail, "INV", "", _
.Fields("inv_id3") & " - " & .Fields("inv_desc"), _
1, lngDetail, "EA", .Fields("rd_total"), Round(.Fields("rd_cost"), 2)
' if there is a special instruction
If Not IsNull(.Fields("rh_spec_instr")) Then
lngComment = lngComment + 10
Write #2, 3, lngCCount, lngComment, lngDetail, 1, .Fields("rh_spec_instr")
End If
' if there is a receiver instruction
If Not IsNull(.Fields("rh_recv_instr")) Then
lngComment = lngComment + 10
Write #2, 3, lngCCount, lngComment, lngDetail, 1, .Fields("rh_recv_instr")
End If
strCLast = strCCurr
Else
strTCurr = .Fields("rh_id")
If strTCurr <> strTLast Then ' If the current receipt isn't the same as the last.
If blnHeaderr = False Then lngTCount = lngTCount + 1
blnHeaderr = False
' Write a header record.
Write #2, 1, lngTCount, Format(.Fields("rh_arrival_date"), "YYYYMMDD"), _
CStr(.Fields("rh_id")), .Fields("ve_acct"), "Receiver import from Apropos", _
.Fields("rh_po_id")
lngDetail = 0
lngComment = 0
lblInfo.Caption = "Doing receipt no: " & .Fields("rh_id") & "..."
Me.Repaint
' Write the optional field
Write #2, 7, lngTCount, "PO", .Fields("rh_po_id")
End If ' End of header writing
' Write the detail line
lngDetail = lngDetail + 100
Write #2, 2, lngTCount, lngDetail, "INV", "", _
.Fields("inv_id3") & " - " & .Fields("inv_desc"), _
1, lngDetail, "EA", .Fields("rd_total"), Round(.Fields("rd_cost"), 2)
' if there is a special instruction
If Not IsNull(.Fields("rh_spec_instr")) Then
lngComment = lngComment + 10
Write #2, 3, lngTCount, lngComment, lngDetail, 1, .Fields("rh_spec_instr")
End If
' if there is a receiver instruction
If Not IsNull(.Fields("rh_recv_instr")) Then
lngComment = lngComment + 10
Write #2, 3, lngTCount, lngComment, lngDetail, 1, .Fields("rh_recv_instr")
End If
strTLast = strTCurr
End If
NextDetail:
If .BOF Or .EOF Then Exit Do
.MoveNext
vLast = vCurr
Loop
End With
Set vVend = Nothing
Close #2
Close #3
Exit Sub
VendErr:
If vCurr <> vLast Then
blnBadVend = True
If blnErr = False Then
Open strErrLog For Output As #1
blnErr = True
Print #1, "The following receipts were not entered for the reasons indicated."
Else
Open strErrLog For Append As #1
End If
Select Case lngVendErr
Case 1
If rsRecpt.Fields("rd_total") > 0 Then
Print #1, "The vendor " & rsRecpt.Fields("ve_acct") & _
" does not exist so " & strCLast & " was not added."
Else
Print #1, "The vendor " & rsRecpt.Fields("ve_acct") & _
" does not exist so " & strTLast & " was not added."
End If
Case 2
If rsRecpt.Fields("rd_total") > 0 Then
Print #1, "The vendor " & rsRecpt.Fields("ve_acct") & _
" is inactive so " & strCLast & " was not added."
Else
Print #1, "The vendor " & rsRecpt.Fields("ve_acct") & _
" is inactive so " & strTLast & " was not added."
End If
Case 3
If rsRecpt.Fields("rd_total") > 0 Then
Print #1, "The vendor " & rsRecpt.Fields("ve_acct") & _
" is on hold so " & strCLast & " was not added."
Else
Print #1, "The vendor " & rsRecpt.Fields("ve_acct") & _
" is on hold so " & strTLast & " was not added."
End If
End Select
Close #1
End If
GoTo NextDetail
End Sub
Private Sub CreateHeaderInfo()
Open "C:\Clients\Zumiez\test.txt" For Output As #2
Write #2, "RECTYPE", "RCPHSEQ", "DATE", "RCPNUMBER", "VDCODE", "DESCRIPTIO", "REFERENCE"
Write #2, "RECTYPE", "RCPHSEQ", "RCPLREV", "ITEMNO", "LOCATION", "ITEMDESC", "HASCOMMENT", "RCPCSEQ", "RCPUNIT", "RQRECEIVED", "UNITCOST"
Write #2, "RECTYPE", "RCPHSEQ", "RCPCREV", "RCPCSEQ", "COMMENTTYP", "COMMENT"
Write #2, "RECTYPE", "RCPHSEQ", "VDCODE"
Write #2, "RECTYPE", "RCPHSEQ", "VDCODE", "RCPSREV"
Write #2, "RECTYPE", "RCPHSEQ", "VDCODE", "RCPSREV", "LSEQ"
Write #2, "RECTYPE", "RCPHSEQ", "OPTFIELD", "VALUE"
Write #2, "RECTYPE", "RCPHSEQ", "RCPLREV", "OPTFIELD"
Write #2, "RECTYPE", "RCPHSEQ", "VDCODE", "OPTFIELD"
Write #2, "RECTYPE", "RCPHSEQ", "VDCODE", "RCPSREV", "OPTFIELD"
Close #2
End Sub