Creating an AIB Credits transfer file in VBA

/1 Comment/in , /by

This is the code I use to create an IBB transfer file, this can be linked to Sage, Syspro, Intact or any Accounting system which allow an ODBC connection. This contains a fe functions such as Getpref which pulls preference data from another table. These can be replaced with static data or your own functions.

The first part makes the the payee file….


Function CreatePayeeFile()
On Error GoTo Errorhandler

DoCmd.Hourglass True

Dim db As Database
Dim rst As Recordset
Dim SqlStr  As String
Dim myfile As Integer, tmpStr As String
Dim tmpfile As String, tmpPath As String

Set db = CurrentDb()
Set rst = db.OpenRecordset("qryPayeeExport")

'assign variables
'file
myfile = FreeFile
'check file name and path
If Len(GetPref("Payee File Name") & "") = 0 Then
    MsgBox ("File name required, please review setup details")
    GoTo Exit_Func
Else
    tmpPath = GetPref("Export File Path")
    tmpfile = GetPref("Payee File Name")
End If

If rst.RecordCount > 0 Then
    'move to the first record
    rst.MoveFirst
    'open the file for output
    Open (tmpPath & "" & tmpfile) For Output As myfile
    Do While Not rst.EOF
        tmpStr = Chr(34) & rst!V_Payee & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_VendorID & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Name & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Address & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Phone & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Fax & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Telex & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Bank_Name & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Bank_Code_Type & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Bank_Code & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Account_Number & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_International & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_EDIFact_ID & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_EDIFACT_Qualifier & Chr(34) & ","
        tmpStr = tmpStr & Chr(34) & rst!V_Vendor_Ref & Chr(34) & ","
        Print #myfile, tmpStr
        rst.MoveNext
    Loop
    'MsgBox ("File Export Complete")
'Else
    'MsgBox ("No Payee Records to Export")
End If
 
Exit_Func:

Set db = Nothing
Set rst = Nothing
DoCmd.Hourglass False
Close #myfile

Exit Function

Errorhandler:
MsgBox "An Error has Occurred " & vbCrLf & _
        "Error Number :" & Err.Number & vbCrLf & _
        "Details :" & Err.Description
        GoTo Exit_Func
        

End Function

The second part creates the payee file

Function CreatePaymentFile()
On Error GoTo Errorhandler

DoCmd.Hourglass True

Dim db As Database
Dim rst As Recordset
Dim SqlStr  As String
Dim myfile As Integer, tmpStr As String, tmpVer As String
Dim tmpfile As String, tmpPath As String, tmpLine As String, tmpComma
tmpComma = ","
Set db = CurrentDb()
Set rst = db.OpenRecordset("qryPaymentFile")
tmpVer = GetPref("AIB Program Version")

'increment the payment run to get a new run number
SetPref "Payment File Name", GetPref("Payment File Name") + 1, "Program", "System"

'assign variables
'file
myfile = FreeFile
'check file name and path
If Len(GetPref("Payment File Name") & "") = 0 Then
    MsgBox ("Payment File name required, please review setup details")
    GoTo Exit_Func
Else
    tmpPath = GetPref("Export File Path")
    tmpfile = right("00000000" & GetPref("Payment File Name"), 8) & ".imp"
End If

If rst.RecordCount > 0 Then
    'move to the first record
    rst.MoveFirst
    'open the file for output
    Open (tmpPath & "" & tmpfile) For Output As myfile
    Do While Not rst.EOF
        tmpLine = ""
        tmpLine = tmpLine & rst!PY_Payer & tmpComma                                   'field 1
        tmpLine = tmpLine & "EUR" & tmpComma                                          'field 2
        tmpLine = tmpLine & "WT" & tmpComma                                           'field 3
        tmpLine = tmpLine & "SHA" & tmpComma                                          'field 4
        tmpLine = tmpLine & rst!PY_Currency & tmpComma                                'field 5
        tmpLine = tmpLine & rst!PY_Amount & tmpComma                                  'field 6
        tmpLine = tmpLine & Format(rst!PY_ValueDate, "DD-MM-YYYY") & tmpComma         'field 7
        tmpLine = tmpLine & Left(RegReplace(rst!V_Name) & "", 35) & tmpComma          'field 8
        tmpLine = tmpLine & Left(RegReplace(rst!V_Address) & "", 35) & tmpComma       'field 9
        tmpLine = tmpLine & "" & tmpComma   'second address line blank                'field 10
        tmpLine = tmpLine & rst!PY_Reference & tmpComma                               'field 11
        tmpLine = tmpLine & "" & tmpComma   'optional unique ref                      'field 12
        tmpLine = tmpLine & rst!V_Account_Number & tmpComma   'Bank account           'field 13
        
        If IsNumeric(Left(rst!V_Bank_Code, 1)) = False Then
            tmpLine = tmpLine & rst!V_Bank_Code & tmpComma   'Bank code               'field 14
            tmpLine = tmpLine & "" & tmpComma   'bank clearing code if no iban        'field 15
            tmpLine = tmpLine & "" & tmpComma   'party bank clearing code if 15 is p  'field 16
        Else
            tmpLine = tmpLine & "" & tmpComma   'Bank code               'field 14
            tmpLine = tmpLine & rst!V_Bank_Code & tmpComma   '                   'field 15
            tmpLine = tmpLine & rst!V_Bank_Code_Type & tmpComma   'party bank clearing code if 15 is pop'field 16
        End If
        tmpLine = tmpLine & rst!V_CountryCode & tmpComma   'bank country code         'field 17
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 18
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 19
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 20
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 21
        tmpLine = tmpLine & "" & tmpComma   'optional                                 'field 22
        tmpLine = tmpLine & ""              'optional                                 'field 23
                
        
        Print #myfile, tmpLine
        
        rst.MoveNext
    Loop
   If MsgBox("Print Reports ", vbYesNo) = vbYes Then
        DoCmd.OpenReport "your reports...."      
   End If
    MsgBox ("File Export Complete")
Else
    MsgBox ("No Payment Records to Export")
End If
 
Exit_Func:

Set db = Nothing
Set rst = Nothing

DoCmd.Hourglass False

Close #myfile

Exit Function

Errorhandler:
MsgBox "An Error has Occurred " & vbCrLf & _
        "Error Number :" & Err.Number & vbCrLf & _
        "Details :" & Err.Description
        GoTo Exit_Func
        

End Function

Creating Excel files from MS Access

/0 Comments/in , , /by

This routine is used to create an inventory forecast, which displays a 52 week forecast based on Sales orders MRP forecast and scheduled PO’s.

Function OpenWritetoXLS_QCS(tmpFiletoOpen, tmpFirstWeek, tmpLastWeek)
Dim objXL As Object
Dim strWhat As String, boolXL As Boolean
Dim objWkb As Object
Dim objSht As Object
Dim rst As Recordset, tmpRange, tmpRangeCount, tmpGonePast, tmpPosition, tmpOffset, I, tmpColumn
tmpGonePast = False
    Set rst = CurrentDb.OpenRecordset("Select * from tblTmpXLFile order by Id") ' this is my access table that contains the records I want to insert into excel
    If rst.RecordCount > 0 Then
        rst.MoveFirst
    Else
        Set rst = Nothing
        MsgBox ("Nothing to export to excel")
        Exit Function
    End If
    tmpRange = ""

    If fIsAppRunning("Excel") Then
        Set objXL = GetObject(, "Excel.Application")
        boolXL = False
    Else
        Set objXL = CreateObject("Excel.Application")
        boolXL = True
    End If
    
    'now open file
  With objXL
  
    .Visible = True
    Set objWkb = .Workbooks.Open(tmpFiletoOpen)
    On Error Resume Next
    Set objSht = objWkb.Worksheets("SHEETNAME")
    If Not Err.Number = 0 Then
      Set objSht = objWkb.Worksheets.Add
      objSht.Name = "SHEETNAME"
    End If
    
    objWkb.Worksheets("SHEETNAME").Activate
    
    objSht.Range("C1").Select
    objXL.ActiveCell.offset(0, 0) = tmpFirstWeek
    
    Err.Clear
    
    On Error GoTo 0
    tmpRangeCount = 1
    With objSht
        Do While Not rst.EOF
            tmpPosition = rst!Cellref ' this notes the line within the Excel model that I want to populate
            'reset to new position
            Select Case tmpPosition
                Case 6
                    .Range("B4").Select
                    tmpOffset = 3
                Case 8
                    .Range("B5").Select
                    tmpOffset = 4
                Case 9
                    .Range("B6").Select
                    tmpOffset = 5
                Case 20
                    .Range("B12").Select
                    tmpOffset = 11
                Case 30
                    .Range("B13").Select
                    tmpOffset = 12
                Case 35
                    .Range("B14").Select
                    tmpOffset = 13
            End Select
            
            'Find out what row we should go to
            tmpColumn = Val(rst!rptLabel)
            tmpColumn = tmpColumn - tmpFirstWeek + 1
            
            If Val(rst!rptLabel) = 0 Then
                objXL.ActiveCell.offset(0, 0) = rst!FIELDNAME
            Else
                objXL.ActiveCell.offset(0, tmpColumn) = rst!FIELDNAME
            End If
            rst.MoveNext
        Loop
    End With

  'update Parameters
    Set objSht = objWkb.Worksheets("Parameters")
    If Not Err.Number = 0 Then
      Set objSht = objWkb.Worksheets.Add
      objSht.Name = "Parameters"
    End If
    
    objWkb.Worksheets("Parameters").Activate
    
    objSht.Range("A1").Select
    objXL.ActiveCell.offset(0, 0) = "Year"
    objXL.ActiveCell.offset(0, 1) = Forms![frmExport]![txtYear]
    objXL.ActiveCell.offset(1, 0) = "Overdue Week"
    objXL.ActiveCell.offset(1, 1) = Forms![frmExport]![txtOverDue]
    objXL.ActiveCell.offset(2, 0) = "Start of Month"
    objXL.ActiveCell.offset(2, 1) = Forms![frmExport]![txtStartofMonth]
    
    objXL.ActiveCell.offset(3, 0) = "First Week"
    objXL.ActiveCell.offset(3, 1) = Forms![frmExport]![txtFirstWeek]
    
    objXL.ActiveCell.offset(3, 0) = "Last Week"
    objXL.ActiveCell.offset(3, 1) = Forms![frmExport]![txtLastWeek]
    
  End With
  
  objWkb.Close savechanges:=True
  
  Set objSht = Nothing
  Set objWkb = Nothing
  Set objXL = Nothing
  Set rst = Nothing
  
End Function

Syspro Server Move

/0 Comments/in , /by

We move server for Syspro version 6 recently and had to update 40 users ODBC connections. The easiest way to complete this was to fix the odbc setting on one computer , then export the registry for the ODBC setting. We moved that exported reg file to our server and sent all Syspro users a link to the registry file which updated the PC’s.

This is a sample of the file contents – you would need to change “YOURSERVER”

Windows Registry Editor Version 5.00

[HKEY_LOCAL_MACHINESOFTWAREODBCODBC.INISyspro6]
“Driver”=”C:\WINDOWS\system32\tsodbc32.dll”
“Description”=”Live”
“Server”=”YOURSERVER”
“Port”=”7000”
“Timeout”=”100”

We also had an issue with DCOM on the server, when enabling business object. The server was MS 2003 and the only way to get the system to operate was to make to posting user an administrator. This was documented in a tech PDF from syspro as noted below. If you know of any other solution please leave me a comment – thanks

Remote calls made by certain users fail
Cause
Changes introduced in Service Pack 1 (SP1) of Windows 2003 Server has resulted in the
failure of remote calls made by users who are not members of either the Administrators
or Distributed COM Users groups on the server.
Remedy
You need to configure the account permissions for remote access to the server (review
the procedure: Configuring account permissions for remote server access).
Alternatively you can add the user that is being used to run the application, to the DCOM
User group on the server. This group should have all of the required permissions
Configuring account permissions for remote server access
The following steps describe how to configure remote access permissions for users who
are not members of the Administrator or DCOM user groups on the server.
1. Launch the Component Services utility (Control Panel > Administrative Tools >
Component Services).
2. Open the My Computer Properties window.
a. Select the Component Services node.
b. Expand the Computers node.
c. Right-click My Computer.
d. Select Properties from the shortcut menu.
3. Configure the required access permissions.
a. Select the Security tab.
b. Select Edit Limits at the Access Permissions field.
c. Add the account that is being used to run the application via DCOM.
d. Enable the Allow option against the Remote Access option.
e. Select OK.
4. Configure the required launch and activation permissions.
a. Select Edit Limits at the Launch and Activation Permissions field.
b. Add the account that is being used to run the application via DCOM.
c. Enable the Allow option against the Remote Launch and Remote Activation
options.
d. Select OK.
5. Apply your selections.
6. Exit the utility.

Downloading XML files into access

/0 Comments/in , , /by

I use this function to download xml files from a ftp server and read the contents into an Access database.

This function deals with the FTP process. I use a licensed product component from chilkatsoft.com call chilkatftp.

Function DownloadFiles()
On Error GoTo ErrorHandler
Dim ftp As New ChilkatFtp2
Dim success As Integer
Dim n As Integer, i As Integer, rst As Recordset, fname As String
Dim tmpFTP, tmpUsername, tmpPassword, tmpRemote, tmpLocalFolder

Application.echo true, "Start FTP Download Check.." & Now()

tmpLocalFolder = "set your local folder here"
tmpFTP = "Enter you FTP Address"
tmpPassword = "Password"
tmpRemote = "Remote ftp folder"
tmpUsername = "Username"

If Right(tmpLocalFolder, 1) <> "" Then
    If Right(tmpLocalFolder, 1) = "/" Then
        tmpLocalFolder = Left(tmpLocalFolder, Len(tmpLocalFolder) - 1) & ""
    Else
        tmpLocalFolder = tmpLocalFolder & ""
    End If
End If

' Any string unlocks the component for the 1st 30-days.
success = ftp.UnlockComponent("enter_your_unlock_code")
If (success <> 1) Then
    Forms![frmFTPSettings]![txtProgress] = ftp.LastErrorText
    Exit Function
End If

Call UpProgress("Connected to Site")
ftp.Hostname = tmpFTP
ftp.UserName = tmpUsername
ftp.Password = tmpPassword

' Connect and login to the FTP server.
success = ftp.Connect()
If (success <> 1) Then
    Forms![frmFTPSettings]![txtProgress] = ftp.LastErrorText '   open form to display the error
    Exit Function
End If

' Change to the remote directory where the files are located.
' This step is only necessary if the files are not in the root directory
' of the FTP account.
success = ftp.ChangeRemoteDir(tmpRemote)
If (success <> 1) Then
    Forms![frmFTPSettings]![txtProgress] = ftp.LastErrorText
    Exit Function
End If

ftp.ListPattern = "*.xml"

'  NumFilesAndDirs contains the number of files and sub-directories
'  matching the ListPattern in the current remote directory.
'
n = ftp.NumFilesAndDirs
If (n < 0) Then
    Forms![frmFTPSettings]![txtProgress] = ftp.LastErrorText
    Exit Function
End If

Application.echo true, n & " Files downloaded "

If (n > 0) Then
    For i = 0 To n - 1
    '
        fname = ftp.GetFilename(i)

        CurrentDb.Execute ("INSERT INTO tblFilesDownloaded ( FTP_FileDownloaded, FTP_Date, FTP_Processed ) SELECT " & Chr(34) & ftp.GetFilename(i) & Chr(34) & " AS Expr1," & "#" & Now() & "#" &" AS Expr2, 0 AS Expr3")
        '  Download the file into the current working directory.
        success = ftp.GetFile(fname, tmpLocalFolder & fname)
        If (success <> 1) Then
            Forms![frmFTPSettings]![txtProgress] = ftp.LastErrorText
            Exit Function
        End If

        '  Now delete the file.
        success = ftp.DeleteRemoteFile(fname)
        If (success <> 1) Then
            Forms![frmFTPSettings]![txtProgress] = ftp.LastErrorText
            Exit Function
        End If
    '
    Next
End If
'
ftp.Disconnect
'
Exit Function
ErrorHandler:
application.echo true, "FTP - An error occurred " & Err.Number & " " & Err.Description & " At:" & Now())
Resume Next

End Function

Posting Sales Orders in Syspro using XML and Business Objects

/1 Comment/in , /by

The task criteria was to load orders from field sales office by adding automation to Excel files or loading XML files into an access database. This allows the client to validate the order entries and ensure all key data is present before attempting to load the orders into Syspro.

This post covers the export of the data from the validated database into Syspro.

To use this code you would need to download and install the free ChilkatXML program see chilkatsoft.com and add a reference to Chilkat XML, DAO 3.6 and Syspro e.Net.

If you any questions on how to use this code please post a question

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

The next stage is to use the file created in ExportXML() to pass to Syspro business objects.

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

Finally you need to Read the results of the post and update the database

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

Exporting Signed Numerics EBCDIC

/0 Comments/in , /by

I needed a function to create an EBCDIC overpunch to numeric values in an access database when exporting the data as text files for loading into OneSource.

This function might help if you need something similar

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

Cycle counting your stock

/0 Comments/in , /by

This sample assumes you have a table of parts that are categorised by warehouse and abc classification (tblCycleCountStockRecords ) . You would have decided how many times you want to count the parts per year (tblCountRotation) and divided that by the number of counts in a year. The code in this function will ensure that for each count you are cycling through your stock records and counting the parts in rotation and getting the number of hits per year per classification.

 

I also load this cycle count data to a handheld computer and have the operator count the stock by location and upload the results for analysis and live system updating.

 

A user screen is presented to the user and they can select the warehouse to add to the cycle count file.

Private Sub cmdAddCount_Click()
'On Error GoTo ErrorHandler

Dim rst As Recordset, rstSource As Recordset, rstTarget As Recordset
Dim tmpCount As Long, tmpRotation As Long, tmpCalcRecord, tmpStartingRecord

If MsgBox("Do you want to add the warehouse " & Me.cboWarehouse & " to the count file", vbYesNo) = vbNo Then
    Exit Sub
End If

Set rst = CurrentDb.OpenRecordset("Select * from tblCycleSelect where WAREHOUSE=" & Chr(34) & Me.cboWarehouse & Chr(34))
If rst.RecordCount> 0 Then
    MsgBox "This warehouse is already in the count file" & vbCrLf & "Please finish the current count before adding this warehouse"
    Exit Sub
End If

Set rst = CurrentDb.OpenRecordset("Select * from tblCountRotation where C_WH=" & Chr(34) & Me.cboWarehouse & Chr(34))
If rst.RecordCount = 0 Then
    MsgBox "No Details match the selected warehouse "
    Exit Sub
End If
rst.MoveFirst

Set rstTarget = CurrentDb.OpenRecordset("select * from tblCycleCountStockRecords ")

tmpRotation = Me.txtRotation + 1

Do While Not rst.EOF
    'set the number of lines to count for this abc catgeory
    tmpCount = rst!C_LineItemsPerCount
    'select the target records
    Set rstSource = CurrentDb.OpenRecordset("select * from tblCycleCountStockRecords  where WAREHOUSE=" & Chr(34) & rst!C_WH & Chr(34) & _
                                            " and I1ABC=" & Chr(34) & rst!C_ABC & Chr(34) & " Order by Control ASC")

    'this calc the number of counts by the count quantity
    tmpCalcRecord = (rst!C_LineItemsPerCount * tmpRotation)
    If rstSource.RecordCount = 0 Then
        GoTo Skip_next
    End If
    If Int(tmpCalcRecord / rst!C_NoofParts) > 0 Then ' check that the calced position is less than total record
        tmpStartingRecord = (tmpCalcRecord - (rst!C_NoofParts * Int(tmpCalcRecord / rst!C_NoofParts))) - rst!C_LineItemsPerCount ' establish starting position
        If tmpStartingRecord < 0 Then tmpStartingRecord = rst!C_NoofParts + tmpStartingRecord
    Else
        tmpStartingRecord = tmpCalcRecord - rst!C_LineItemsPerCount ' less than total record start = calced minus count qty
    End If

    rstSource.Move tmpStartingRecord
    Do While tmpCount >= 0
        If rstSource.EOF Then
            rstSource.MoveFirst
        End If
        'add the records to the count file
        With rstTarget
            Application.Echo True, "Processing Part Number: " &rstSource!StkCode
            .AddNew
            !StkCode= rstSource!StkCode
            !Warehouse = rstSource!Warehouse
            !Bin = rstSource! Bin
            !Description = rstSource! Description
            !UnitofMeasure = rstSource! UnitofMeasure
            !ABC = rstSource!ABC
            .Update
        End With
        rstSource.MoveNext
        tmpCount = tmpCount - 1
    Loop
    'update the rotation on the master file
    rst.Edit
    rst!C_CurrentRotation = tmpRotation
    rst.Update
Skip_next:
    'next abc
    rst.MoveNext

Loop

MsgBox "Finsihed!"
Set rst = Nothing
Set rstSource = Nothing
Set rstTarget = Nothing

Exit Sub

ErrorHandler:
MsgBox "An error occurred when loading the data " & vbCrLf &
        " Error Number: " & Err.Number & vbCrLf & " Details: " & Err.Description
        DoCmd.Hourglass False
        Exit Sub

End Sub