Creating Excel files from MS Access

Apr 24
2010

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

Apr 16
2010

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_MACHINE\SOFTWARE\ODBC\ODBC.INI\Syspro6]
“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

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

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

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