Accounting systems

Dim xml As ChilkatXml
Dim rec1 As ChilkatXml, rec0 As ChilkatXml
Dim tmpLines(500, 10), i As Integer, tmpCount As Integer ' change the array depth if needed
Dim tmpHeader(25) ' change to the number of headers filds you have
Dim rst As Recordset, rstStock As Recordset
Dim x As Integer
 
' Load the input document.
Set xml = New ChilkatXml
xml.LoadXMLFile tmpFile ' tmpfile is the XML file passed to this function

'Header
Set rec1 = xml.FindChild("Header")
    If (rec1.FindChild2("OrderNumber") = 1) Then
        tmpHeader(1) = rec1.Content
        rec1.GetParent2
    End If
    If (rec1.FindChild2("CreationDate") = 1) Then
        tmpHeader(2) = rec1.Content
        rec1.GetParent2
    End If
    If (rec1.FindChild2("CompanyCode") = 1) Then
        tmpHeader(3) = Right("000" & rec1.Content, 3)
        rec1.GetParent2
    End If
 
'ship address
Set rec1 = xml.FindChild("Partners")
    If (rec1.FindChild2("Identifier") = 1) Then
        tmpHeader(4) = rec1.Content
        rec1.GetParent2
    End If
    If (rec1.FindChild2("Name1") = 1) Then
        tmpHeader(5) = rec1.Content
        rec1.GetParent2
    End If
    If (rec1.FindChild2("Name2") = 1) Then
        tmpHeader(6) = rec1.Content
        rec1.GetParent2
    End If
    If (rec1.FindChild2("Street") = 1) Then
        tmpHeader(7) = rec1.Content
        rec1.GetParent2
    End If
 
    If (rec1.FindChild2("PostCode") = 1) Then
        tmpHeader(8) = rec1.Content
        rec1.GetParent2
    End If
    If (rec1.FindChild2("CountryCode") = 1) Then
        tmpHeader(9) = rec1.Content
        rec1.GetParent2
    End If
 
    If (rec1.FindChild2("City") = 1) Then
        tmpHeader(10) = rec1.Content
        rec1.GetParent2
    End If
 
Set rec1 = xml.FindChild("Items")
 
If (rec1.FirstChild2() = 0) Then
    Set rec1 = Nothing
End If
 
Set rec0 = rec1.GetParent()
 
i = 1
Do While Not (rec0 Is Nothing)
 
    If (rec0.FindChild2("Material") = 1) Then
        tmpLines(i, 1) = rec0.Content
        rec0.GetParent2
    End If
 
    If (rec0.FindChild2("Description") = 1) Then
        tmpLines(i, 2) = rec0.Content
        rec0.GetParent2
    End If
 
    If (rec0.FindChild2("Quantity") = 1) Then
        tmpLines(i, 3) = rec0.Content
        rec0.GetParent2
    End If
 
    If (rec0.FindChild2("DeliveryDate") = 1) Then
        tmpLines(i, 4) = rec0.Content
        rec0.GetParent2
    End If
 
    If (rec0.FindChild2("PricePerUnit") = 1) Then
        tmpLines(i, 5) = rec0.Content
        rec0.GetParent2
    End If
 
    If (rec0.FindChild2("ItemText") = 1) Then
        tmpLines(i, 6) = "" & rec0.Content
        rec0.GetParent2
    End If
 
    If (rec0.FindChild2("InfoRecordPOText") = 1) Then
        tmpLines(i, 7) = "" & rec0.Content
        rec0.GetParent2
    End If
 
    If (rec0.FindChild2("MaterialPOText ") = 1) Then
        tmpLines(i, 8) = "" & rec0.Content
        rec0.GetParent2
    End If
 
    If (rec0.FindChild2("DeliveryText") = 1) Then
        tmpLines(i, 9) = "" & rec0.Content
        rec0.GetParent2
    End If
 
    'now check for vendor material number
    If (rec0.FindChild2("VendorMaterialNumber") = 1) Then
        tmpLines(i, 10) = "" & rec0.Content
        rec0.GetParent2
    End If
 
    ' Move to the next sibling. The internal reference within node is updated
    ' to the node's next sibling. If no siblings remain, it returns 0.
    If (rec0.NextSibling2() = 0) Then
        Set rec0 = Nothing
    End If
 
    i = i + 1
 
Loop
 
' now write the data into the tblImport
Set rst = CurrentDb.OpenRecordset("tblImportData")
 
tmpCount = 0
x = 1
Do While Len(tmpLines(x, 2) & "") > 0
    rst.AddNew
    'rst!O_Number = tmpHeader(1)
    rst!O_Entity = tmpHeader(3)
    rst!O_Date = DateSerial(Left(tmpHeader(2), 4), Val(Left(Right(tmpHeader(2), 4), 2)), Val(Right(tmpHeader(2), 2)))
    If Len(tmpLines(x, 1) & "") > 0 Then
        rst!O_Part = tmpLines(x, 1)
    Else
        'try the vendor material number
        rst!O_Part = tmpLines(x, 10)
    End If
    'rst!O_AltPArt = tmpLines(x, 1)
    rst!O_PartOrg = tmpLines(x, 1)
    rst!O_Desc = tmpLines(x, 2)
    rst!O_Qty = tmpLines(x, 3)
    rst!O_Price = tmpLines(x, 5)
    rst!O_Price2 = tmpLines(x, 5)
    rst!O_Extended = Val(Nz(tmpLines(x, 5), 0)) * Val(Nz(tmpLines(x, 3), 0))
    rst!O_ImpDate = Date
    rst!O_ShipName = tmpHeader(5)
    rst!O_Ship1 = tmpHeader(6)
    rst!O_Ship2 = tmpHeader(7)
    rst!O_Ship3 = tmpHeader(8)
    rst!O_Ship4 = tmpHeader(9)
    rst!O_Ship5 = tmpHeader(10)
    'rst!O_Ship6=""
    rst!O_Processed = 0
    rst!O_Failed = 0
    rst!O_Validated = 0
    rst!O_Disc = 0
    rst!O_Number = tmpHeader(1) & "-" & rst!O_Warehouse
    Set rstStock = Nothing
 
    rst!O_PriceList = "A"
    'rst!O_FailReason
    'rst!O_ORder
    'rst!O_Master
    rst!O_LineShipDate = DateSerial(Left(tmpLines(x, 4), 4), Val(Left(Right(tmpLines(x, 4), 4), 2)), Val(Right(tmpLines(x, 4), 2)))
    'rst!O_OrderDate
    rst!O_Inactive = 0
    rst!O_Text = tmpLines(x, 6) & vbCrLf & tmpLines(x, 7) & vbCrLf & tmpLines(x, 8) & vbCrLf & tmpLines(x, 9) & vbCrLf
    rst.Update
    tmpCount = tmpCount + 1
    x = x + 1
Loop
If tmpCount > 0 Then
    MsgBox "Order Loaded"
Else
    MsgBox "No order lines loaded - check XML File"
End If
 
End Function

Function EbcDic(ByVal tmpNumber As Double, ByVal tmpDec As Integer, ByVal tmpPlaces As Integer)
'--------------------------------------------------------------------------------------
'OneSource Requirement for Signed Numeric Fields
'Below is the conversion table of signed numeric values (right most over-punch character) to EBCIDIC:
'(you do not need to worry about positive numbers, it is only negative numbers that need the translation)

'Positive   'Negative
'0 = {      '0 = }
'1 = A      '1 = J
'2 = B      '2 = K
'3 = C      '3 = L
'4 = D      '4 = M
'5 = E      '5 = N
'6 = F      '6 = O
'7 = G      '7 = P
'8 = H      '8 = Q
'9 = I      '9 = R
'
'  (for example a -592.52 ... will be passed as 00000005925K)
'--------------------------------------------------------------------------------------

Dim tmpStr, tmpTrans, tmpPos, tmpFactor
Dim tmpFilled
tmpFilled = "00000000000000"
 
If Len(tmpNumber & "") = 0 Then
    EbcDic = right(tmpFilled, tmpPlaces)
    Exit Function
End If
 
Select Case tmpDec
Case 0
    tmpFactor = 1
Case 1
    tmpFactor = 10
Case 2
    tmpFactor = 100
Case 3
    tmpFactor = 1000
Case 4
    tmpFactor = 10000
End Select
 
If tmpNumber >= 0 Then
    EbcDic = right(tmpFilled & Int(tmpNumber * tmpFactor), tmpPlaces)
    Exit Function
Else
    tmpTrans = Int((tmpNumber * tmpFactor) * -1)
    tmpPos = InStr(1, "0123456789", right(tmpTrans, 1), 1)
 
    tmpStr = Left(tmpTrans, (Len(tmpTrans) - 1)) & right(Left("}JKLMNOPQR", tmpPos), 1)
   EbcDic = right(tmpFilled & tmpStr, tmpPlaces)
End If
 
End Function

Function SpecialReplace(ByVal tmpReg) As String
If Len(tmpReg) > 0 Then
    Dim tmpStr
    'start the replace
    'clear double spaces
    tmpStr = Trim(tmpReg)
    tmpStr = FindAndReplace(tmpStr, "ä", "a") ' ) bracket
    tmpStr = FindAndReplace(tmpStr, "Ä", "A") ' ) bracket
    tmpStr = FindAndReplace(tmpStr, "é", "e") ' ) bracket
    tmpStr = FindAndReplace(tmpStr, "ö", "o") ' ) bracket
    tmpStr = FindAndReplace(tmpStr, "Ö", "O") ' ) bracket
    tmpStr = FindAndReplace(tmpStr, "ü", "u") ' ) bracket
    tmpStr = FindAndReplace(tmpStr, "Ü", "U") ' ) bracket
    tmpStr = FindAndReplace(tmpStr, "ß", "s") ' ) bracket
    tmpStr = FindAndReplace(tmpStr, "Å", "A")
    tmpStr = FindAndReplace(tmpStr, "å", "a")
    tmpStr = FindAndReplace(tmpStr, "Æ", "A")
    tmpStr = FindAndReplace(tmpStr, "æ", "a")
    tmpStr = FindAndReplace(tmpStr, "Ø", "O")
    SpecialReplace = tmpStr
End If
End Function

''************ Code Start **********
'This code was originally written by Alden Streeter.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Alden Streeter
'
Function FindAndReplace(ByVal strInString As String, strFindString As String, strReplaceString As String) As String
Dim intPtr As Integer
    If Len(strFindString) > 0 Then  'catch if try to find empty string
        Do
            intPtr = InStr(strInString, strFindString)
            If intPtr > 0 Then
                FindAndReplace = FindAndReplace & Left(strInString, intPtr - 1) & strReplaceString
                    strInString = Mid(strInString, intPtr + Len(strFindString))
            End If
        Loop While intPtr > 0
    End If
    FindAndReplace = FindAndReplace & strInString
End Function

Sub Macro1()
'
' change the value of x to the number of lines to fill
Dim I, x
x=1500
Do While I < x
    If ActiveCell.Value = "" Then
        ActiveCell.Offset(-1, 0).Select
        Selection.Copy
        ActiveCell.Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    ActiveCell.Offset(1, 0).Select
    I = I + 1
Loop
End Sub

Function ChangeVat()
On Error GoTo Error_Handler
 
DoCmd.Hourglass True
'check defaults
Application.Echo True, "Updating Program Data"
 
Dim oSDO As SageDataObject150.SDOEngine
Dim oWS As SageDataObject150.Workspace
Dim strDataPath As String
Dim oSalesRecord As SageDataObject150.SalesRecord
Dim oSalesDeliveryRecord As SageDataObject150.SalesDeliveryRecord
Dim bFlag As Boolean
Dim i As Integer, tmpInt As Long, tmpProg As Long, tmpCount, tmpLetter As String, tmpType As Double
 
Application.Echo True, "Checking for Sage Preferences to Add"
 
If ChkPrefs = False Then
    GoTo Sage_ExitImport
End If
 
' Create the SDOEngine Object
Set oSDO = New SageDataObject150.SDOEngine
' Create the Workspace
Set oWS = oSDO.Workspaces.Add("Example")
' Select company the select company method

' Connect to Data Files
oWS.Connect "Line50 Directory", "Login Name", "Login Password", "Example"
 
' Create Instance of Sales Record Object
Set oSalesRecord = oWS.CreateObject("SalesRecord")
' goto the first sales ledger record

oSalesRecord.MoveFirst
 
Do
        ' Edit the Record
        If oSalesRecord.Edit Then
            ' Change the Account Name
            oSalesRecord.Fields.Item("DEf_TAX_CODE").Value = 2
        ' Update the Record
            If oSalesRecord.Update Then
                ' The Update was Successful
                Application.Echo True, "Account " & oSalesRecord.Fields.Item("ACCOUNT_REF").Value &" was edited successfully."
            Else
                ' The Update was Unsuccessful
                MsgBox "The account could not be edited."
            End If
        End If
 
 Loop Until (Not oSalesRecord.MoveNext)
'--------------------
'Export the Products
'------------------
Dim oStockRecord As SageDataObject150.StockRecord
Dim oPriceRecord As SageDataObject150.PriceRecord
Dim oControlData As SageDataObject150.ControlData
 
' Create Instance of StockRecord Object
Set oStockRecord = oWS.CreateObject("StockRecord")
Set oPriceRecord = oWS.CreateObject("PriceRecord")
tmpCount = oStockRecord.Count
tmpProg = 1
oStockRecord.MoveFirst
Do
 
        ' Edit the Record
        If oStockRecord.Edit Then
            oStockRecord.Fields.Item("TAX_CODE").Value = 2
        ' Update the Record
            If oStockRecord.Update Then
                ' The Update was Successful
                Application.Echo True, "Account " & oStockRecord.Fields.Item("STOCK_CODE").Value & " was edited successfully."
            Else
                ' The Update was Unsuccessful
                MsgBox "The account could not be edited."
            End If
        End If
 
Loop Until (Not oStockRecord.MoveNext)
 
'Close connections
Set oStockRecord = Nothing
Set oControlData = Nothing
 
Sage_ExitImport:
 
' Disconnect and Destroy the Objects
oWS.Disconnect
Set oSalesRecord = Nothing
Set oSDO = Nothing
Set oWS = Nothing
DoCmd.Hourglass False
 
Exit Function
 
' Error Handling Code
Error_Handler:
Call SageError(oSDO.LastError.Code, oSDO.LastError.text, Err.Number, Err.Description, "Sage Import")
 
DoCmd.Hourglass False
Resume Sage_ExitImport
 
End Function

 
Function fncCreateInvoices(ByVal tmpDate As Date)
 
On Error GoTo Error_Handler
 
'i use the date passed to filter the invoice table from MASC
If Not IsDate(tmpDate) Then
    MsgBox "Please enter a valid date"
    Exit Function
End If
 
DoCmd.Hourglass True
 
' Declare Objects
Dim oSDO As SageDataObject120.SDOEngine
Dim oWS As SageDataObject120.Workspace
Dim oInvoicePost As SageDataObject120.InvoicePost
Dim oInvoiceItem As SageDataObject120.InvoiceItem
Dim oSalesRecord As SageDataObject120.SalesRecord
Dim oStockRecord As SageDataObject120.StockRecord
Dim oSalesDeliveryRecord As SageDataObject120.SalesDeliveryRecord
 
Dim db As Database
Dim rstSource As Recordset, rstTrans As Recordset, strAccount
Dim tmpTranCust, tmpUseON As Boolean, tmpTranDD As String, tmpUseCPO As Boolean
 
 
 
Set db = CurrentDb
 
' Declare Variables
Dim strDataPath As String
Dim bFlag As Boolean
Dim iCtr As Integer
 
'sage initialise
' Create the SDO Engine Object
Set oSDO = New SageDataObject120.SDOEngine
 
' Create the Workspace
Set oWS = oSDO.Workspaces.Add("Example")
 
'Check that the selected invoices have a customer record See older posts for Actdate
Set rstSource = db.OpenRecordset("select * from QryCheckInvDates where tDate<=#" & ActDate(tmpDate) & "#")
Application.Echo True, "Checking Customers"
If rstSource.RecordCount > 0 Then
  If MsgBox("Some customer records are missing in sage, print a listing ?", vbYesNo) = vbYes Then
      DoCmd.OpenReport "rptMissingCustomers", acViewPreview
      GoTo Exit_Function
  Else
      MsgBox "Add the new customers to proceed"
      GoTo Exit_Function
  End If
End If
Application.Echo True, "Checking for Invoices to Add"
' create export code
Set rstSource = db.OpenRecordset("select * from qryInvoicestoExport where Value>0 and tDate<=#" & ActDate(tmpDate) & "# ORDER by Ref ASC")
If rstSource.RecordCount = 0 Then
      MsgBox "Nothing to process"
      GoTo Exit_Function
Else
  rstSource.MoveFirst
End If
 
Application.Echo True, "Checking for Sage Preferences to Add"
 
If ChkPrefs = False Then
    GoTo Exit_Function
End If
 
' Connect to Data Files
oWS.Connect "Line50 Directory","Login Name","Login Password", "Example"
 
Application.Echo True, "Connected to Sage"
 
'loop the record source
Do While Not rstSource.EOF
 
' Create an instance of InvoicePost & Record object's
 Set oSalesRecord = oWS.CreateObject("SalesRecord")
 Set oInvoicePost = oWS.CreateObject("InvoicePost")
 Set oStockRecord = oWS.CreateObject("StockRecord")
 
 
 
 ' Set the type of invoice for the next available number
 oInvoicePost.Type = sdoLedgerInvoice
 
 'get the transactions
 Set rstTrans = db.OpenRecordset("Select * from qryTrans Where hInvoiceno=" & rstSource!REF)
 If rstTrans.RecordCount = 0 Then
   MsgBox "No Transactions for invoice " & rstSource!REF
   GoTo loop_routine
 End If
 
 Application.Echo True, "Processing Invoice " & rstSource!REF
 
 
 
 ' Use the invoice number assigned from masc
 oInvoicePost.Header("Invoice_Number") = rstSource!REF
 
 ' Loop for Number of Items on the Invoice
       iCtr = 0
       tmpTranCust = ""
       Do While Not rstTrans.EOF
 
           Set oInvoiceItem = oInvoicePost.Items.Add()
         iCtr = iCtr + 1
 
         ' Initialise Index Field with value to search
         oStockRecord("Stock_CODE") = CStr(rstTrans!HprodC)
         If oSalesRecord.Find(False) Then
           oInvoiceItem("Stock_Code") = CStr(oStockRecord("Stock_Code"))
           oInvoiceItem("Description") = nullCstr(rstTrans!HInvText)
           oInvoiceItem("Comment_1") = nullCstr(rstTrans!HInvText)
           oInvoiceItem("Nominal_Code") = CStr(oStockRecord("Nominal_Code"))
           oInvoiceItem("Tax_Code") = CInt(Right(rstTrans!HVatRate, 1))
         Else
           oInvoiceItem("Stock_Code") = CStr(rstTrans!HprodC)
           oInvoiceItem("Description") = nullCstr(rstTrans!HInvText)
           oInvoiceItem("Comment_1") = nullCstr(rstTrans!HInvText)
           oInvoiceItem("Nominal_Code") = CStr(GetPref("Default Sales Nominal"))
           oInvoiceItem("Tax_Code") = CInt(Right(rstTrans!HVatRate, 1))
         End If
 
         ' Populate other fields required for Invoice Item
         oInvoiceItem("Qty_Order") = CDbl(rstTrans!HQty)
         oInvoiceItem("Unit_Price") = CDbl(rstTrans!HPrice)
         oInvoiceItem("Net_Amount") = CDbl(rstTrans!HLineValue)
         oInvoiceItem("Tax_Amount") = CDbl(rstTrans!HVatVal)
         oInvoiceItem("Comment_2") = CStr("Date:" & Format(rstTrans!HDATE, "dd/mm/yy"))
         oInvoiceItem("Unit_Of_Sale") = CStr("")
         oInvoiceItem("Full_Net_Amount") = CDbl(rstTrans!HVatVal + rstTrans!HLineValue)
         oInvoiceItem("Tax_Rate") = CDbl(rstTrans!VT_Rate)
         tmpTranCust = rstTrans!HCustCode
         tmpTranDD = nullCstr(rstTrans!HSuppref)
         rstTrans.MoveNext
      Loop ' on trans

 
 ' Populate Invoice Header Information
 oInvoicePost.Header("Invoice_Date") = CDate(rstSource!TDate)
 oInvoicePost.Header("Notes_1") = CStr("")
 oInvoicePost.Header("Notes_2") = CStr("")
 oInvoicePost.Header("Notes_3") = CStr("")
 oInvoicePost.Header("Taken_By") = CStr("")
 oInvoicePost.Header("Order_Number") = IIf(tmpUseON, Left(CStr(tmpTranDD), 7), "")
 oInvoicePost.Header("Cust_Order_Number") = IIf(tmpUseCPO, Left(CStr(tmpTranDD), 7), "")
 oInvoicePost.Header("Payment_Ref") = CStr("")
 oInvoicePost.Header("Global_Nom_Code") = CStr("")
 oInvoicePost.Header("Global_Details") = CStr("")
 oInvoicePost.Header("Invoice_Type_Code") = CByte(sdoProductInvoice)
 oInvoicePost.Header("Items_Net") = CDbl(rstSource!InvNet)
 oInvoicePost.Header("Items_Tax") = CDbl(rstSource!InvVat)
 
 ' Read the first customer
 strAccount = CStr(rstSource!ID)
 strAccount = strAccount & String(8 - Len(strAccount), 32)
 oSalesRecord("Account_Ref") = strAccount
 
 bFlag = oSalesRecord.Find(False) '("ACCOUNT_REF", strAccount)
 If bFlag Then
 oInvoicePost.Header("Account_Ref") = CStr(rstSource!ID) 'oSalesRecord("Account_Ref"))
 oInvoicePost.Header("Name") = CStr(oSalesRecord("Name"))
 oInvoicePost.Header("Address_1") = CStr(oSalesRecord("Address_1"))
 oInvoicePost.Header("Address_2") = CStr(oSalesRecord("Address_2"))
 oInvoicePost.Header("Address_3") = CStr(oSalesRecord("Address_3"))
 oInvoicePost.Header("Address_4") = CStr(oSalesRecord("Address_4"))
 oInvoicePost.Header("Address_5") = CStr(oSalesRecord("Address_5"))
 Set oSalesDeliveryRecord = oWS.CreateObject("SalesDeliveryRecord")
 Dim bEnd
 bEnd = False
 If Not IsNull(tmpTranCust) Or Len(tmpTranCust) <> 0 Then
   oSalesDeliveryRecord.MoveFirst
   Do
       If oSalesDeliveryRecord("DESCRIPTION") = tmpTranCust Then
         bEnd = True
         oInvoicePost.Header("DELIVERY_NAME") = CStr(oSalesDeliveryRecord("NAME"))
         oInvoicePost.Header("Del_Address_1") = CStr(oSalesDeliveryRecord("Address_1"))
         oInvoicePost.Header("Del_Address_2") = CStr(oSalesDeliveryRecord("Address_2"))
         oInvoicePost.Header("Del_Address_3") = CStr(oSalesDeliveryRecord("Address_3"))
         oInvoicePost.Header("Del_Address_4") = CStr(oSalesDeliveryRecord("Address_4"))
         oInvoicePost.Header("Del_Address_5") = CStr(oSalesDeliveryRecord("Address_5"))
         oInvoicePost.Header("Cust_Tel_Number") = CStr(oSalesDeliveryRecord("Telephone"))
         oInvoicePost.Header("Contact_Name") = CStr(oSalesDeliveryRecord("Contact_Name"))
       End If
   Loop Until (bEnd Or Not oSalesDeliveryRecord.MoveNext)
 
End If
End If
 ' Update the Invoice
 bFlag = oInvoicePost.Update
 If bFlag Then
   Application.Echo True, "Invoice Created Successfully :" & rstSource!REF
   db.Execute ("Update tblbillings set ar_PRocessed=-1 where ref=" & rstSource!REF)
 Else
   Application.Echo True, "Invoice Not Created"
 End If
loop_routine:
 
rstSource.MoveNext
 
Set oSalesRecord = Nothing
Set oInvoicePost = Nothing
Set oInvoiceItem = Nothing
Set oSalesDeliveryRecord = Nothing
 
 
Loop ' on rstsource

 
Exit_Function:
 
' Disconnect and Destroy Objects
oWS.Disconnect
Set oSDO = Nothing
Set oWS = Nothing
Set db = Nothing
Set rstSource = Nothing
Set rstTrans = Nothing
 
DoCmd.Hourglass False
 
Exit Function
' Error Handling Code
Error_Handler:
Call SageError(oSDO.LastError.Code, oSDO.LastError.Text, Err.Number, Err.Description, "Sage Invoice Export")
 
DoCmd.Hourglass False
Resume Exit_Function
 
 
End Function

Function ExportXML()
' this function will use a validated export table of data to create the xml file
'and pass this file to be executed by Syspro
'Structure creted on 3-Apr
Dim xml As New ChilkatXml
Dim HeaderNode As ChilkatXml
Dim OrderNode As ChilkatXml
Dim OrderHeaderNode As ChilkatXml
Dim OrderDetailsNode As ChilkatXml
Dim OrderDetailsStockLineNode As ChilkatXml
Dim OrderDetailsCommentLineNode As ChilkatXml
Dim OrderDetailsMiscChargeLineNode As ChilkatXml
Dim OrderDetailsFreightLineNode As ChilkatXml
 
Dim tmpOrderNumber, tmpEntityNumber, tmpOrderLine
Dim rst As Recordset
 
Set HeaderNode = xml.NewChild("TransmissionHeader", "")
Set OrderNode = xml.NewChild("Orders", "")
 
xml.Tag = "SalesOrders"
'set the header values
HeaderNode.NewChild2 "TransmissionReference", "000003"     'rst!ID 'use the id of the passed recordset
HeaderNode.NewChild2 "SenderCode", ""
HeaderNode.NewChild2 "ReceiverCode", "HO"
HeaderNode.NewChild2 "DatePRepared", Format(Date, "yyyy-mm-dd")
HeaderNode.NewChild2 "TimePrepared", Format(Now(), "hh:nn")
 
Set rst = CurrentDb.OpenRecordset("qryImportData_Filtered") ' this is a filtered list of the record to upload
If rst.RecordCount = 0 Then
    MsgBox "Nothing to Process"
    GoTo Exit_Func
    Exit Function
Else
    rst.MoveFirst
End If
 
tmpEntityNumber = ""
tmpOrderNumber = ""
tmpOrderLine = 1
 
'Set OrderHeaderNode = OrderNode.NewChild("OrderHeader", "")

Do While Not rst.EOF
 
If tmpEntityNumber <> rst!O_Entity Or tmpOrderNumber <> rst!O_Number Then
    'Must be a new order - write the header data and fill the static details
    Set OrderHeaderNode = OrderNode.NewChild("OrderHeader", "")
    Set OrderDetailsNode = OrderNode.NewChild("OrderDetails", "")
 
    tmpEntityNumber = rst!O_Entity
    tmpOrderNumber = rst!O_Number
    tmpOrderLine = 1
 
    'Add the order header values
    OrderHeaderNode.NewChild2 "CustomerPoNumber", rst!O_Number     'get from recordset
    OrderHeaderNode.NewChild2 "OrderActionType", tmpOrderActionType     'get from variables
    OrderHeaderNode.NewChild2 "NewCustomerPoNumber", ""
    OrderHeaderNode.NewChild2 "Supplier", ""
    OrderHeaderNode.NewChild2 "Customer", rst!O_Entity
    OrderHeaderNode.NewChild2 "OrderDate", Format(Date, "yyyy-mm-dd")
    OrderHeaderNode.NewChild2 "InvoiceTerms", ""
    OrderHeaderNode.NewChild2 "Currency", ""
    OrderHeaderNode.NewChild2 "ShippingInstrs", ""
    OrderHeaderNode.NewChild2 "CustomerName", Left(rst!O_ShipName & "", 30)
    OrderHeaderNode.NewChild2 "ShipAddress1", Left(rst!O_Ship1 & "", 40)
    OrderHeaderNode.NewChild2 "ShipAddress2", Left(rst!O_Ship2 & "", 40)
    OrderHeaderNode.NewChild2 "ShipAddress3", Left(rst!O_Ship3 & "", 40)
    OrderHeaderNode.NewChild2 "ShipAddress4", Left(rst!O_Ship4 & "", 40)
    OrderHeaderNode.NewChild2 "ShipAddress5", Left(rst!O_Ship5 & "", 40)
    OrderHeaderNode.NewChild2 "ShipPostalCode", Left(rst!O_Ship6 & "", 9) 'had issues with null values so added the quotes
    OrderHeaderNode.NewChild2 "Email", ""
    OrderHeaderNode.NewChild2 "OrderDiscPercent1", ""
    OrderHeaderNode.NewChild2 "OrderDiscPercent2", ""
    OrderHeaderNode.NewChild2 "OrderDiscPercent3", ""
    OrderHeaderNode.NewChild2 "Warehouse", "" 'rst!O_Warehouse '
    OrderHeaderNode.NewChild2 "SpecialInstrs", ""
    OrderHeaderNode.NewChild2 "SalesOrder", ""
    OrderHeaderNode.NewChild2 "OrderType", ""
    OrderHeaderNode.NewChild2 "MultiShipCode", ""
    OrderHeaderNode.NewChild2 "AlternateReference", ""
    OrderHeaderNode.NewChild2 "Salesperson", ""
    OrderHeaderNode.NewChild2 "Branch", ""
    OrderHeaderNode.NewChild2 "Area", rst!O_Area '""
    OrderHeaderNode.NewChild2 "RequestedShipDate", ""
    OrderHeaderNode.NewChild2 "InvoiceNumberEntered", ""
    OrderHeaderNode.NewChild2 "InvoiceDateEntered", ""
    OrderHeaderNode.NewChild2 "OrderComments", ""
    OrderHeaderNode.NewChild2 "Nationality", ""
    OrderHeaderNode.NewChild2 "DeliveryTerms", ""
    OrderHeaderNode.NewChild2 "TransactionNature", ""
    OrderHeaderNode.NewChild2 "TransportMode", ""
    OrderHeaderNode.NewChild2 "ProcessFlag", ""
    OrderHeaderNode.NewChild2 "TaxExemptNumber", ""
    OrderHeaderNode.NewChild2 "TaxExemptionStatus", ""
    OrderHeaderNode.NewChild2 "GstExemptNumber", ""
    OrderHeaderNode.NewChild2 "GstExemptionStatus", ""
    OrderHeaderNode.NewChild2 "CompanyTaxNumber", ""
    OrderHeaderNode.NewChild2 "CancelReasonCode", ""
    OrderHeaderNode.NewChild2 "DocumentFormat", ""
    OrderHeaderNode.NewChild2 "State", ""
    OrderHeaderNode.NewChild2 "CountyZip", ""
    OrderHeaderNode.NewChild2 "City", ""
    OrderHeaderNode.NewChild2 "eSignature", ""
    tmpHonApo = rst!O_HonAffPO
End If
 
    Set OrderDetailsStockLineNode = OrderDetailsNode.NewChild("StockLine", "")
 
    ' ad criteria to define the line type in the order import
    'get the stock line itmes
    OrderDetailsStockLineNode.NewChild2 "CustomerPoLine", tmpOrderLine
    tmpOrderLine = tmpOrderLine + 1
    OrderDetailsStockLineNode.NewChild2 "LineActionType", tmpLineActionType
    OrderDetailsStockLineNode.NewChild2 "LineCancelCode", ""
    OrderDetailsStockLineNode.NewChild2 "StockCode", rst!O_Part
    OrderDetailsStockLineNode.NewChild2 "StockDescription", "" 'Left(rst!sDescription & "", 30)
    OrderDetailsStockLineNode.NewChild2 "Warehouse", rst!O_Warehouse  'tmpDefaultWarehouse
    OrderDetailsStockLineNode.NewChild2 "CustomersPartNumber", rst!O_AltPArt &""
    OrderDetailsStockLineNode.NewChild2 "OrderQty", rst!O_Qty
    OrderDetailsStockLineNode.NewChild2 "OrderUom", rst!stockuom & ""
    OrderDetailsStockLineNode.NewChild2 "Price", IIf(tmpLoadPrice, rst!O_Price, "")
    OrderDetailsStockLineNode.NewChild2 "PriceUom", rst!stockuom & ""
    OrderDetailsStockLineNode.NewChild2 "PriceCode", rst!O_PriceList '""
    OrderDetailsStockLineNode.NewChild2 "AlwaysUsePriceEntered", ""
    OrderDetailsStockLineNode.NewChild2 "Units", ""
    OrderDetailsStockLineNode.NewChild2 "Pieces", ""
    OrderDetailsStockLineNode.NewChild2 "ProductClass", rst!productclass & ""
    OrderDetailsStockLineNode.NewChild2 "LineDiscPercent1", ""
    OrderDetailsStockLineNode.NewChild2 "LineDiscPercent2", ""
    OrderDetailsStockLineNode.NewChild2 "LineDiscPercent3", ""
    OrderDetailsStockLineNode.NewChild2 "CustRequestDate", ""
    OrderDetailsStockLineNode.NewChild2 "CommissionCode", ""
    OrderDetailsStockLineNode.NewChild2 "LineShipDate", Format(rst!O_LineShipDate, "yyyy-mm-dd")
    OrderDetailsStockLineNode.NewChild2 "LineDiscValue", ""
    OrderDetailsStockLineNode.NewChild2 "LineDiscValFlag", ""
    OrderDetailsStockLineNode.NewChild2 "OverrideCalculatedDiscount", ""
    OrderDetailsStockLineNode.NewChild2 "UserDefined", ""
    OrderDetailsStockLineNode.NewChild2 "NonStockedLine", ""
    OrderDetailsStockLineNode.NewChild2 "NsProductClass", ""
    OrderDetailsStockLineNode.NewChild2 "NsUnitCost", ""
    OrderDetailsStockLineNode.NewChild2 "UnitMass", ""
    OrderDetailsStockLineNode.NewChild2 "UnitVolume", ""
    OrderDetailsStockLineNode.NewChild2 "StockTaxCode", ""
    OrderDetailsStockLineNode.NewChild2 "StockNotTaxable", ""
    OrderDetailsStockLineNode.NewChild2 "StockFstCode", ""
    OrderDetailsStockLineNode.NewChild2 "StockNotFstTaxable", ""
    OrderDetailsStockLineNode.NewChild2 "ConfigPrintInv", ""
    OrderDetailsStockLineNode.NewChild2 "ConfigPrintDel", ""
    OrderDetailsStockLineNode.NewChild2 "ConfigPrintAck", ""
 
    'Set OrderDetailsCommentLineNode = OrderDetailsNode.NewChild("CommentLine", "")
    'get the comment lines
    'OrderDetailsCommentLineNode.NewChild2 "CustomerPoLine", "2"     'get from recordset

    'Set OrderDetailsMiscChargeLineNode = OrderDetailsNode.NewChild("MiscChargeLine", "")
    'get the Misc line details
    'OrderDetailsMiscChargeLineNode.NewChild2 "CustomerPoLine", "3"     'get from recordset

    'Set OrderDetailsFreightLineNode = OrderDetailsNode.NewChild("FreightLine", "")
    'get the Freight Line Details
    'OrderDetailsFreightLineNode.NewChild2 "CustomerPoLine", "4"     'get from recordset

rst.MoveNext ' goto the next line

Loop
 
'  Save the XML:
Dim success As Long
success = xml.SaveXml("c:\XMLSO.xml")
If (success <>1) Then
    MsgBox xml.LastErrorText
End If
 
Exit_Func:
Set rst = Nothing
Set HeaderNode = Nothing
Set OrderNode = Nothing
Set OrderHeaderNode = Nothing
Set OrderDetailsNode = Nothing
Set OrderDetailsStockLineNode = Nothing
Set OrderDetailsCommentLineNode = Nothing
Set OrderDetailsMiscChargeLineNode = Nothing
Set OrderDetailsFreightLineNode = Nothing
 
End Function

Function OrdPost()
On Error GoTo Errorhandler
Dim XMLout, xmlIn, XMLPar
Dim xml As New ChilkatXml
Dim rec1 As ChilkatXml
Dim rec2 As ChilkatXml
 
Call ExportXML
 
Call SysproLogon
 
Dim EncPost As New Encore.Transaction
XMLPar = "Add the xml parameters here"
 
'xmlIn = xml.LoadXml("c:\xmlso.xml")
Open "c:\xmlso.xml" For Input As #1
xmlIn = Input(LOF(1), 1)
Close #1
 
'xml.LoadXmlFile ("c:\XMLSO.xml")

'actually post the order
XMLout = EncPost.Post(Guid, "SORTOI", XMLPar, xmlIn)
xml.LoadXml (XMLout)
 
xml.SaveXml ("c:\SORTOIOUT.xml")
'now see if there have been any errors
Call ReadResults
 
Exit Function
Errorhandler:
 
MsgBox Err.Number & " " & Err.Description
End Function

Function ReadResults()
 
On Error GoTo Errorhandler
Dim XMLout, xmlIn, XMLPar
Dim xml As New ChilkatXml
Dim rec1 As ChilkatXml
Dim rec2 As ChilkatXml
Dim rec3 As ChilkatXml
Dim rec4 As ChilkatXml
Dim rec5 As ChilkatXml
Dim rst As Recordset, tmpReason, tmpSql
 
Dim tmpMEssage1
Dim tmpMessage2, tmpOrder, tmpStkCode, tmpMessage(20)
Dim x
 
xml.LoadXMLFile ("c:\SORTOIOUT.xml")
'search for status
Set rec4 = xml.SearchForTag(Nothing, "SalesOrder")
tmpMessage(2) = rec4.Content
 
'mark order processed if we have a sales order number
If Len(tmpMessage(2) & "") > 0 Then
    CurrentDb.Execute ("UPDATE tblImportData SET O_Processed = -1 WHERE  O_Number=" & Chr(34) & tmpPorder & Chr(34) & " AND O_Entity=" & Chr(34) & tmpPcountry & Chr(34))
 
End If
 
If Len(tmpMessage(2) & "") = 0 Then
    Set rec4 = xml.SearchForTag(Nothing, "Status")
    tmpMessage(1) = rec4.Content
 
    'search for Errormessages
    Set rec4 = xml.SearchForTag(Nothing, "ErrorDescription")
    tmpMessage(3) = rec4.Content
 
    ' Find the first article beginning with M
    Set rec1 = xml.SearchForTag(Nothing, "Customer")
    tmpMessage(4) = rec1.Content
    Debug.Print tmpMessage(4)
 
    Set rec1 = xml.SearchForTag(Nothing, "CustomerPoNumber")
 
    tmpMessage(5) = rec1.Content
    Debug.Print tmpMessage(5)
 
End If
 
'write the overall status
Set rst = CurrentDb.OpenRecordset("tblResults")
With rst
    .AddNew
    !R_Customer = tmpPcountry
    !R_Order = tmpPorder
    !R_StockCode = ""
    !R_Error = tmpMessage(1) & " Reason: " & tmpMessage(3)
    !R_SYSOrder = tmpMessage(2)
    !R_MAster = "Y"
    !R_Added = Now()
    .Update
End With
Set rst = Nothing
 
Set rec2 = xml.SearchForTag(rec1, "StockCode")
 
Do While Not rec2 Is Nothing
 
    tmpMessage(6) = rec2.Content
    Debug.Print tmpMessage(6)
 
    Set rec3 = xml.SearchForTag(rec2, "ErrorMessages")
    Do While Not rec3 Is Nothing
        Set rec4 = rec3.SearchForTag(Nothing, "ErrorDescription")
        x = 6
        Do While Not rec4 Is Nothing
            x = x + 1
            tmpMessage(x) = rec4.Content
            Debug.Print tmpMessage(x)
 
            'find the next message
            Set rec4 = rec3.SearchForTag(rec4, "ErrorDescription")
        Loop
        Set rec3 = rec2.SearchForTag(rec3, "ErrorMessages")
    Loop
 
    'nowWrite the Results if an error occurred
    If Len(tmpMessage(4) & "") > 0 Then
        Set rst = CurrentDb.OpenRecordset("tblResults")
        With rst
        Do While x >= 7
            .AddNew
            !R_Customer = tmpPcountry
            !R_Order = tmpPorder
            !R_StockCode = tmpMessage(6)
            !R_Error = tmpMessage(x)
            !R_MAster = "N"
            !R_Added = Now()
            .Update
            tmpMessage(x) = ""
            x = x - 1
        Loop
        End With
        Set rst = Nothing
    End If
Set rec2 = xml.SearchForTag(rec2, "StockCode")
Loop
 
'now update syspro results
Call UpdateArea
 
Exit Function
 
Errorhandler:
 
End Function

 
Function LoadCust()
On Error GoTo Intact_Error
Dim IntactTable As New INTACTSDKTable
Dim tmpLastRecord, r, tmpCount, tmpCompany, tmpRcode
 
tmpRcode = GetPref("RouteCode Field Name")
 
Application.Echo True, "Linking to selected Intact Company"
 
tmpCompany = GetPref("Intact Company")
IntactTable.CompanyDirectory (tmpCompany)
IntactTable.TableName ("CUSTS")
 
'Clear customers and set reference to table
CurrentDb.Execute ("Delete * from tblCustomers")
CurrentDb.Execute ("Delete * from tblCustMemo")
Dim rstCust As Recordset
Set rstCust = CurrentDb.OpenRecordset("tblCustomers")
 
r = IntactTable.First
tmpLastRecord = True
tmpCount = 1
 
Do
    rstCust.AddNew
 
    'Assign details
    rstCust!ID = IntactTable.fieldvalueasstring("CODE")
    Application.Echo True, "Adding Customer Seq:" & tmpCount & " :" & IntactTable.fieldvalueasstring("CODE")
    tmpCount = tmpCount + 1
    rstCust!CustBarcode = IntactTable.fieldvalueasstring("CODE")
    rstCust!CompanyName = IntactTable.fieldvalueasstring("NAME")
    rstCust!Add1 = IntactTable.fieldvalueasstring("ADR1")
    rstCust!Add2 = IntactTable.fieldvalueasstring("ADR2")
    rstCust!Add3 = IntactTable.fieldvalueasstring("ADR3")
    rstCust!Town = IntactTable.fieldvalueasstring("ADR4")
    rstCust!County = IntactTable.fieldvalueasstring("ADR5")
    rstCust!Phone = IntactTable.fieldvalueasstring("PHONE1")    
    rstCust!CPriceCode = IIf(Len(IntactTable.fieldvalueasstring("LISTCODE") & "") = 0, IntactTable.fieldvalueasstring("CODE"), IntactTable.fieldvalueasstring("LISTCODE"))
    'Check Delivery Address
    If Len(IntactTable.fieldvalueasstring("HOCODE") & "") > 0 Then
        rstCust!MasterAccount = IntactTable.fieldvalueasstring("HOCODE")
        rstCust!DeliveryAddress = -1
    Else
        rstCust!DeliveryAddress = 0
    End If
    rstCust!RouteCode = IntactTable.fieldvalueasstring("Repcode") 'tmpRcode) 'repcode
    'Frequency Check
    If Len(IntactTable.fieldvalueasstring("XXFREQ") & "") <> 0 And IntactTable.fieldvalueasstring("XXFREQ") <> "INVALID" Then
        rstCust!Frequency = IntactTable.fieldvalueasstring("XXFREQ")
    Else
        rstCust!Frequency = "Docket"
    End If
    'Priced Check
    If IntactTable.fieldvalueasstring("XXPRICED") = "t" Then
        rstCust!Priced = -1
    Else
        rstCust!Priced = 0
    End If
    'Active Check
    If IntactTable.fieldvalueasstring("XXACTIVE") = "t" Or IntactTable.fieldvalueasstring("XXACTIVE") = "INVALID" Or IntactTable.fieldvalueasstring("XXACTIVE") = "" Then
        rstCust!Active = -1
    Else
        rstCust!Active = 0
    End If
 
    If IntactTable.fieldvalueasstring("ForceVat") = "T" Then
        rstCust!C_Vol1 = 1
        rstCust!C_Vol2 = IntactTable.fieldvalueasstring("DefVatCode")
    Else
        rstCust!C_Vol1 = 0
    End If
 
    'Other Fields
    rstCust!InvoiceMovements = -1
    rstCust!Currency = "EUR"
    rstCust!Orders = 0
    rstCust!MESSCHK = 0
    rstCust!CustType = "RET"
    'Update record
    rstCust.Update
 
    r = IntactTable.Next
 
    If r = -90 Then tmpLastRecord = False
 
    If IntactTable.fieldvalueasstring("CODE") = "" Then
        tmpLastRecord = False
    End If
Loop While tmpLastRecord
 
Set rstCust = Nothing
Set IntactTable = Nothing
 
Exit Function
 
Intact_Error:
MsgBox "Intact Customer List Refresh " & Err.Number & vbCrLf & "Details " & Err.Description & vbCrLf & "Intact Msg:" & GetIntactMsg(Err.Number)
 
Set rstCust = Nothing
Set IntactTable = Nothing
 
End Function