Posts

Creating an AIB Credits transfer file in VBA

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

Downloading XML files into access

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

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

Outlook blocks MDB file attachments

This is a registry fix to a constant problem sending mdb files using outlook, the recipient does not get the file as outlook has blocked the display. I take no credit for this fix for the full article see this reference http://www.slipstick.com/outlook/esecup/getexe.asp. The following is an extract from that page for my reference.

Outlook 2007, Outlook 2003, Outlook 2002 and Outlook 2000 SP3 (but not Outlook 98 or earlier Outlook 2000 versions) allow the user to use a registry key to open up access to blocked attachments. (Always make a backup before editing the registry.) To use this key:
1.Run Regedit, and go to this key:

HKEY_CURRENT_USERSoftwareMicrosoftOffice10.0OutlookSecurity (change 10.0 to 9.0 for Outlook 2000 SP3 or to 11.0 for Outlook 2003, 12.0 for Outlook 2007 )
2.Under that key, add a new string value named Level1Remove.
3.For the value for Level1Remove, enter a semicolon-delimited list of file extensions. For example, entering this:

.mdb;.url

would unblock Microsoft Access files and Internet shortcuts. Note that the use of a leading dot was not previously required, however, new security patches may require it. If you are using “mdb;url” format and extensions are blocked, add a dot to each extension. Note also that there is not a space between extensions.

Exporting Signed Numerics EBCDIC

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

Scheduling Access Jobs

I used MS scheduler before I found this product from Spliterware ( they say – ‘System Scheduler is an excellent tool to schedule unattended running of applications, batch files, scripts and much more.’)

 

The sample screen below shows the setting I use with Access 2003

 

When used with Access I have a form called frmAutoLoad , when the form is loaded I have an on load event which checks the current time. If the time is not between 10pm and 6am I close the form and open the normal menu. I also add a time event which executes after 25 seconds, this lets the user stop the auto update process if used out of hours.

 

Scheduling Access Jobs screen1

 

Once you have configured the event you can then schedule the occurances.

 

Scheduling Access Jobs screen2

Reading a SAP XML file into Access

I use a free product call chilkatxml from chilkatsoft.com, The site has loads of samples but initially I found it difficult to iteriate through the record loops in the xml file.  I have detailed the code I used to load XML orders into an access database.

The first phase is to read the file into an array and the second phase will post that array into an access database. This is similar to theExcel to Access sample but I am using an array to store the data.

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

Posting Invoices into Sage Line 50 from an Access Database

Sage Line 50 allows direct read/write access to many of the tables in Sage through the Sage Data Objects. To use this you will need to have the file sd0engxx0.tlb where xx is the sage version number.

2 keys issues I have had in loading data into sage

1. Ensure the values passed to Sage are not null, convert your values to strings where appropriate
2. The values passed to Sage are not longer than the field width

Sounds obvious but I missed both of these in earlier program versions.

The following Sample shows an invoice been posted from an access table to Sage.


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

Downloading Customer data from Intact Business Accounting

Intact Business Accounting has an SDK which is exposed for all developers and available in the system.  The following sample shows how we load the customer data into an Access database for use with our MASC Product. IF you are using Intact and have any questions leave me a comment and I will reply.


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

Adding Data from an excel file to Access

I wrote this macro to populate an access database with the contents from a protected spreadsheet that was distributed to users in different countries. The Excel file was used for Sales Order Entry. I have removed sections for security purposes, however this should serve as a good starting point for you to start your own version.

The idea is to ensure that the data integrity before loading the file and then marking the excel file as imported to prevent accidental duplication in the upload.

I have added comments to the code to explain the main sections, If you have any questions leave a comment.

'generic format

Sub XML_LoadXLTemplate()
' ExportData Macro
' Version 1.0 2-Apr-09
' Designed to export data to the xml data store
'-------------------------------------------------
Dim tmpTest As Boolean, myfile, tmpStr, tmpFile, tmpPath, x, tmpCells, tmpCount, tmpShipName, tmpAPO
Dim rst As Recordset, db As Database, tmpCountry, tmpEntity, tmpODate, tmpOrderRef, tmpShip5, tmpShip6
Dim tmpShip1, tmpShip2, tmpShip3, tmpShip4, tmpArea, tmpWH, tmpPriceList, tmpStartSheet, tmpShipDate
Dim tmpFailures, rstStock As Recordset, tmpRequestor
Dim tmpPhone, tmpEmail, tmpAttention, tmpWarranty, tmpCrystal, tmpShipVia, tmpShipViaAccount

'|------------------------------------
'|need to set a reference to DAO , under tools
'|references Microsoft DAO 3.6...
'|--------------------------------------

Set db = OpenDatabase("\serverYouDatabase.mdb")
Set rst = db.OpenRecordset("tblImportData")

tmpTest = True
tmpStr = ""

Application.ScreenUpdating = False
tmpStartSheet = ActiveSheet.Name

Range("I1").Select
' This cell is populated after the data is imported to ensure the user does not accidentally duplicate the load

If ActiveCell.Value = "Data Imported" Then
    If MsgBox("This sheet has already been imported, Import Again ?", vbYesNo + vbDefaultButton2) = vbNo Then
        Exit Sub
    End If
End If

Range("A1").Select

If FoundWS("SheetName") = False Then  ' FOR FUNCTION SEE http://www.ozgrid.com/forum/showthread.php?t=38108
    MsgBox "Cannot find the Order Sheet SheetName"
    Exit Sub
End If

Sheets("SheetName").Select

'now check the control cells
tmpFailures = ""

Range("D6").Select
If Len(ActiveCell.Value & "") = 0 Then
    tmpFailures = tmpFailures & "This Order must Contain the Entity Code at D6" & vbCrLf
End If

Range("D7").Select
If Len(ActiveCell.Value & "") = 0 Then
    tmpFailures = tmpFailures & "No Entity name entered at D7 " & vbCrLf
End If
' you can add as many checks to the integrity of the sheet before starting the load

'now check the order lines
Range("a28").Select
i = 1
Do While i < 86 ' I had max 86 lines to validate
    If ActiveCell.Offset(0, 7).Value > 0 Then
        If Len(ActiveCell.Offset(0, 1).Value & "") = 0 Then
            tmpFailures = tmpFailures & "Order Line #" & i & " No part number entered" & vbCrLf
        End If
    End If
    i = i + 1
    ActiveCell.Offset(1, 0).Select
Loop

If Len(tmpFailures & "") > 0 Then
    MsgBox "Order Validation Failed " & vbCrLf & vbCrLf & tmpFailures
    Exit Sub
End If

'now move to the first line defined by A2

Range("d6").Select

'set the variables

tmpEntity = ActiveCell.Value
tmpCountry = ActiveCell.Offset(1, 0).Value
tmpShipName = ActiveCell.Offset(3, 0).Value
tmpShip1 = ActiveCell.Offset(4, 0).Value
tmpShip2 = ActiveCell.Offset(5, 0).Value
tmpShip3 = ActiveCell.Offset(6, 0).Value
tmpShip4 = ActiveCell.Offset(7, 0).Value
tmpShip5 = ActiveCell.Offset(8, 0).Value
tmpShip6 = ActiveCell.Offset(9, 0).Value
tmpAttention = ActiveCell.Offset(10, 0).Value
tmpPhone = ActiveCell.Offset(11, 0).Value
tmpEmail = ActiveCell.Offset(12, 0).Value

Range("A28").Select
tmpCells = 28

'move to the start
Cells(tmpCells, 1).Select

'check the value in a1 & h1 is numeric
Do While tmpCount < 86
    If ActiveCell.Offset(0, 7).Value > 0 Then
        'Add the contents to the database
        With rst
            .AddNew
            !O_Entity = tmpEntity
            !O_Date = tmpODate
            !O_Part = ActiveCell.Offset(0, 1).Value
            !O_PartOrg = ActiveCell.Offset(0, 1).Value
            '!O_AltPart = ActiveCell.Offset(0, 2).Value
            !O_Desc = Left(ActiveCell.Offset(0, 3).Value, 200)
            !O_qty = ActiveCell.Offset(0, 7).Value
            !O_price = ActiveCell.Offset(0, 9).Value
            !O_Price2 = 0 'ActiveCell.Offset(0, 9).Value
            !O_Extended = !O_qty * !O_price 'ActiveCell.Offset(0, 7).Value
            !O_ImpDate = Now()
            !O_LineShipDate = IIf(Len(ActiveCell.Offset(0, 7).Value & "") = 0, tmpShipDate, ActiveCell.Offset(0, 7).Value)
            !O_OrderDate = tmpODate
            !O_Ship1 = tmpShip1
            !O_Ship2 = tmpShip2
            !O_Ship3 = tmpShip3
            !O_Ship4 = tmpShip4
            !O_Ship5 = tmpShip5
            !O_Ship6 = Left(tmpShip6, 9)
            !O_ShipName = tmpShipName
            !O_Phone = tmpPhone
            !O_EmailAddress = tmpEmail
            !O_Crystalid = tmpCrystal
            !O_Warranty = tmpWarranty
            !O_ShipVia = tmpShipVia & " " & tmpShipViaAccount
            !O_Requestor = tmpRequestor
            !O_Attention = tmpAttention
            !O_Text = 1
            !O_Warehouse = ""
            !O_Number = tmpOrderRef & "-" & !O_Warehouse

            Set rstStock = Nothing

            !O_PriceList = "A"

            .Update
        End With
    End If
    ActiveCell.Offset(1, 0).Select
    tmpCount = tmpCount + 1
Loop

MsgBox "Database updated"

End Sub