Downloading XML files into access

Nov 25
2009

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 &#038; " 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

Nov 15
2009

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

Nov 13
2009

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

Nov 11
2009

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

Nov 06
2009

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

Loading foreign characters into Syspro

Nov 04
2009

I had an issue loading address fields with swedish and german characters into syspro via an XML upload so used this function to strip out the characters

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

 

You will need the function below from Alden Streeter

''************ 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) &gt; 0 Then  'catch if try to find empty string
        Do
            intPtr = InStr(strInString, strFindString)
            If intPtr &gt; 0 Then
                FindAndReplace = FindAndReplace &amp; Left(strInString, intPtr - 1) &amp; strReplaceString
                    strInString = Mid(strInString, intPtr + Len(strFindString))
            End If
        Loop While intPtr &gt; 0
    End If
    FindAndReplace = FindAndReplace &amp; strInString
End Function

If you need some help on a project drop leave a comment on the post and I will reply.