This is the AllocateProducts function placed in a module called
modInventory.
Option Compare Database 'Use database order for string comparisons
Option Explicit
Dim mlngLineNum As Long, mlngErr As Long, mstrError As String
Function AllocateProducts(lngOrder As Long, _
Optional intSilent As Integer = 0, _
Optional varDate As Variant) As Integer
'
' Inputs: Order ID
' Optional "run silent" indicator (used by zfrmLoadData)
' Optional process date (used by zfrmLoadData)
'
' Output: Returns "True" (-1) if all Products allocated successfully
' Returns +1 if Products allocated and purchase order(s) generated
' Returns "False" (0) if an error occurs
'
' Technique:
' This routine attempts to allocate the required Products.
' Uses "zqryOrderProductSelect" to find Products where Status not
' On Order, Allocated, or Invoiced. If Product is being returned
(negative
' quantity), posts to Inventory or the original PO as appropriate.
' If Product is being ordered (positive quantity), allocates from stock
' in inventory. At end of allocation if some still not allocated from
' inventory, then stuffs the unordered Products in ztTblProductsToOrder
' and calls the common PO build routine.
'
' Note: When called from zfrmLoadData, intSilent is True - procedure will
' open no forms and will not display any errors. zfrmLoadData also
' passes the date it wants to use as the allocation / PODate date.
'
Dim db As DAO.Database, qd As DAO.QueryDef, qdA As DAO.QueryDef
Dim rsA As DAO.Recordset, rsI As DAO.Recordset, rsS As DAO.Recordset
Dim rst As DAO.Recordset, rsP As DAO.Recordset, rsC As DAO.Recordset
Dim varQuantity As Variant, intQuantityReq As Integer
Dim varRet As Variant, intEditA As Integer, intRecCount As Integer
Dim intI As Integer, intSomeError As Integer, intSomeLeft As Integer
Dim intCount As Integer, intQty As Integer, intMult As Integer
Dim intL As Integer, curMinPrice As Currency, curCost As Currency
Dim curPrice As Currency, varCost As Variant, varPrice As Variant
Dim lngPO As Long, lngVendor As Long, intTrans As Integer
Dim lngProductID As Long, lngThisLine As Long, intAddedSome As Integer
Dim intDoPO As Integer, datAllocDate As Date, lngVend As Long
Dim rstW As DAO.Recordset, strSQL As String, strMsg As String
On Error Resume Next
' Set up for default false return
AllocateProducts = 0
' Set up the allocation date
datAllocDate = Date
' If passed a date variable
If Not IsMissing(varDate) Then
' .. and it's a valid date
If IsDate(varDate) Then
' Use the parameter value
datAllocDate = varDate
End If
End If
' Point to this database
Set db = DBEngine(0)(0)
' Open the Order and lock it!
Set rstW = db.OpenRecordset("Select OrderID From tblOrders " & _
"Where OrderID = " & lngOrder)
If rstW.EOF Then
If Not intSilent Then
MsgBox "Unexpected error: Can't find Order #" & _
lngOrder, vbCritical, gstrAppTitle
End If
Exit Function
End If
' Lock the order by editing it
rstW.Edit
If Err <> 0 Then
strMsg = "Error trying to edit Order #" & lngOrder
strMsg = strMsg & ". Someone else may be editing this Order."
If Not intSilent Then MsgBox strMsg, vbExclamation, gstrAppTitle
Exit Function
End If
' Set an error trap
On Error GoTo AllocOrderProducts_ERR
' Clean out working table to store Products not in stock
db.Execute "Delete * FROM zttblProductsToOrder;", dbFailOnError
' Turn on the hourglass and start a transaction
DoCmd.Hourglass True
BeginTrans
intTrans = True
' Open a recordset on Products to allocate
Set qdA = db.QueryDefs("zqryOrderProductSelect")
qdA![OrderParm] = lngOrder
Set rsA = qdA.OpenRecordset()
' Open the inventory table
Set rsI = db.OpenRecordset("tblInventory")
' Get count of Products to allocate rows for SysCmd
rsA.MoveLast
intRecCount = rsA.RecordCount
rsA.MoveFirst
' Show a progress meter
varRet = SysCmd(acSysCmdInitMeter, "Updating Inventory...", intRecCount)
' Loop through all Products to allocate, deduct from stock,
' and adjust master Inventory row
Do Until rsA.EOF
' If returning products, ...
If rsA![AmtNeeded] < 0 Then
' See if return is to a Purchase Order
If IsNothing(rsA!OrderPONo) Then
' If no PO to credit, then return to inventory
intQty = rsA![AmtNeeded]
' Find the inventory record
rsI.FindFirst "ProductID = " & rsA!ProductID
If rsI.NoMatch Then
' Ooops -- can't find the inventory record to return
' the Product!
intSomeError = True
strMsg = "Error attempting to return Product # "
strMsg = strMsg & rsA!ProductID & " to inventory."
strMsg = strMsg & " Inventory record not found."
strMsg = strMsg & " The Order record has been deleted."
If Not intSilent Then MsgBox strMsg, _
vbCritical, gstrAppTitle
' Delete the Order row
rsA.Delete
Else
' Found the Inventory row - edit it to lock it
rsI.Edit
' Find the matching Stock row for an inventory return
strSQL = "Select * From tblStock Where ([ProductID] = "
strSQL = strSQL & rsA!ProductID
strSQL = strSQL & ") And ([Cost] = " & rsA!Cost & ")"
' If there's a VendorID, then also filter for vendor
If Not IsNothing(rsA!VendorID) Then
strSQL = strSQL & " AND ([VendorID] = " & _
rsA!VendorID & ")"
lngVendor = rsA!VendorID
End If
' Open the Stock recordset
Set rsS = db.OpenRecordset(strSQL)
If rsS.EOF Then
' Ooops -- can't find the stock row to return
' the Product!
intSomeError = True
strMsg = "Error attempting to return Product # "
strMsg = strMsg & rsA!ProductID & " to stock."
strMsg = strMsg & " Stock record that matches the "
strMsg = strMsg & "vendor and cost not found."
strMsg = strMsg & " The Order record has been
deleted."
If Not intSilent Then MsgBox strMsg, _
vbCritical, gstrAppTitle
' Delete the Order row
rsA.Delete
Else
' Return the Products to the Stock record
rsS.Edit
' Subtract from Allocated amount -
' product now available back in stock
' NOTE: QuantityAllocated can be negative if
' previously allocated product was already
' invoiced. Will correct when invoiced item
credited.
rsS!QuantityAllocated = rsS!QuantityAllocated + _
rsA!AmtNeeded
rsS!QuantityRemaining = rsS!Quantity - _
(rsS!QuantityAllocated + rsS!QuantitySold + _
rsS!QuantityReturned)
lngVendor = rsS!VendorID
rsS.Update
intQuantityReq = 0
End If
rsS.Close
' Refresh the master inventory totals...
rsI.Edit
' Using a query here so that this routine will
' see the updated quantities within the transaction.
Set qd = db.QueryDefs("zqrySumStockParm")
qd!ItemToFind = rsA!ProductID
Set rst = qd.OpenRecordset()
' Update the calc values in the Inventory row.
If Not rst.EOF Then
rsI!HighCost = rst!MaxCost
rsI!QuantityInStock = rst!Available
rsI!QuantityOnHand = rst!Remain
Else
rsI!QuantityInStock = 0
rsI!QuantityOnHand = 0
End If
rst.Close
Set rst = Nothing
qd.Close
Set qd = Nothing
rsI.Update
' Update the Order status
rsA.Edit
rsA!Status = OrderStatus.Allocated
rsA!DateAlloc = datAllocDate
rsA!VendorID = lngVendor
rsA.Update
End If
Else
' There's a PO Number, so credit back to the PO!
' Open a recordset on PO Products to insert the row
Set rsP = db.OpenRecordset("zqryPOProductsForAlloc", _
dbOpenDynaset, dbAppendOnly)
' Insert a new PO Product row to queue up the credit
' Get "next" line no --
' must use recordset inside a transaction!
Set rsC = db.OpenRecordset("Select Max([LineNo]) As
[LastLineNo] " & _
"From tblPOProducts " & _
"Where [PONumber] = " & rsA!OrderPONo)
If IsNull(rsC!LastLineNo) Then
intL = 1
Else
intL = rsC!LastLineNo + 1
End If
rsC.Close
rsP.AddNew
rsP!PONumber = rsA!OrderPONo
' Setting the PO Number should "autolookup"
' the Vendor ID from the PO
If IsNothing(rsP!POVend) Then
' Ooops - means the PO does not exist!
If Not intSilent Then
MsgBox "Error attempting to credit product # " & _
rsA!ProductID & " to purchase order # " &
rsA!OrderPONo & _
". The Purchase Order cannot be found. " & _
"The PO Number in the Order has been zeroed.", _
vbCritical, gstrAppTitle
End If
intSomeError = True
rsA.Edit
' Zero out the PO Number
rsA!OrderPONumber = 0
rsA.Update
' Discard the POProduct row
rsP.Close
Set rsP = Nothing
Else
' OK - have a good PO, so set the rest of the fields
rsP!LineNo = intL
' copy Vendor ID from the Purchase Order
rsP!VendorID = rsP!POVend
lngVendor = rsP!POVend
' Copy the Product ID
rsP!ProductID = rsA!ProductID
' Save the quantity required
intQty = rsA![AmtNeeded]
' .. and the order multiple
' (number of sell units in one purchase unit)
intMult = rsA![OrderMultiple]
' Set the return quantity
rsP!SellQuantity = intQty
' If the quantity is an even multiple
If intQty Mod intMult = 0 Then
' Do an integer divide to get the amount to order
rsP!BuyQuantity = intQty \ intMult
Else
' else round up to the next buy amount
rsP!BuyQuantity = (intQty \ intMult) + 1
End If
' Set the order by ("case", "pallet")
rsP!OrderBy = rsA![OrderBy]
' Set the sell by ("each", "case")
rsP!SellBy = rsA![SellBy]
' Set the order multiple
rsP!OrderMultiple = intMult
' Use the vendor cost
rsP!Cost = rsP!VendCost
' Use price from the order
rsP!Price = rsA!Price
' Save the new PO Product row
rsP.Update
rsP.Close
Set rsP = Nothing
' Update the Order status
rsA.Edit
' Put the vendor we found in the order
rsA!VendorID = lngVendor
' Set the related PO line number
rsA!OrderPOLineNo = intL
' Mark the status "on order"
rsA!Status = OrderStatus.OnOrder
rsA.Update
' Finally, get the PO and unset its Completed flag
db.Execute ("Update tblPurchaseOrders " & _
"Set [Completed] = False " & _
"Where [PONumber] = " & rsA!OrderPONo)
End If
End If
' End of code to process returns
Else
' Start of code to process positive allocations
' Quantity is positive -- go try to allocate from inventory
intQuantityReq = rsA!AmtNeeded
' Find the Product in the master inventory table
rsI.FindFirst "ProductID = " & rsA!ProductID
If Not rsI.NoMatch Then
' We found the inventory row -- check for quantity available
If rsI!QuantityOnHand > 0 Then
' Looks like some in stock,
' so open a recordset on the stock rows
strSQL = "Select * From tblStock"
strSQL = strSQL & " Where [ProductID] = " &
rsA!ProductID
strSQL = strSQL & " AND QuantityRemaining > 0"
strSQL = strSQL & " ORDER BY [DateReceived]"
' Recordset plucks off the oldest rows first
Set rsS = db.OpenRecordset(strSQL)
If Not rsS.EOF Then
rsS.Edit
' If this stock record has enough, then ...
If intQuantityReq <= rsS!QuantityRemaining Then
' .. pluck the Products from this stock row and
we're done
' Add the quantity needed to Stock Allocated
rsS!QuantityAllocated = rsS!QuantityAllocated +
_
intQuantityReq
' Reduce quantity remaining by quantity needed
rsS!QuantityRemaining = rsS!QuantityRemaining -
_
intQuantityReq
' Save the record
rsS.Update
' Got it all - set required to zero
intQuantityReq = 0
Else
' .. otherwise, grab what's available
' Take whatever is remaining and add it to
allocated
rsS!QuantityAllocated = rsS!QuantityAllocated +
_
rsS!QuantityRemaining
' Reduce required by amount that was remaining
intQuantityReq = intQuantityReq - _
rsS!QuantityRemaining
' Set remaining to zero
rsS!QuantityRemaining = 0
' Save the record
rsS.Update
End If
' Save the cost for updating the Order row
curCost = rsS!Cost
' Save the vendor ID for updating the Order row
lngVendor = rsS!VendorID
rsS.Close
' We're going to update the Order, so edit the row
rsA.Edit
' Update the Order with what we found in stock...
' If quantity remaining, then this will
' reduce the original quantity
rsA!AmtNeeded = (rsA!AmtNeeded - intQuantityReq)
' Set in the allocated found cost
rsA!Cost = curCost
' Set this amount allocated
rsA!Status = OrderStatus.Allocated
' Set the allocation date
rsA!DateAlloc = datAllocDate
' Update the Vendor ID
rsA!VendorID = lngVendor
' Save the Order record
rsA.Update
' Refresh the master inventory totals...
rsI.Edit
' Using a query here so that this routine '
' will see the updated quantities
' within the transaction.
Set qd = db.QueryDefs("zqrySumStockParm")
qd!ItemToFind = rsA!ProductID
Set rst = qd.OpenRecordset()
' Update the "unnormalized" calc values
' in the Inventory row.
If Not rst.EOF Then
rsI!HighCost = rst!MaxCost
rsI!QuantityInStock = rst!Available
rsI!QuantityOnHand = rst!Remain
Else
rsI!QuantityInStock = 0
rsI!QuantityOnHand = 0
End If
rst.Close
qd.Close
' Update the inventory master
rsI.Update
End If
End If
End If
' See if any remaining to allocate
If intQuantityReq > 0 Then
' Did we allocate any on the current row?
If rsA!Status = OrderStatus.Allocated Then
' Yes - need to create a new row
' with remaining quantity!
' Save the line number to get back
lngThisLine = rsA!LineNo
' Save values for new row
lngProductID = rsA!ProductID
curCost = rsA!Cost
curPrice = rsA!Price
' Now, add a new Order row!
' This is a cool trick in DAO - the new row will come up
for
' processing at the end of the current recordset, so
we'll
' keep looking for available Stock records at other
costs until
' we either allocate all requested or end up with a
left over
' amount to stuff in a Purchase Order.
rsA.AddNew
intAddedSome = True
' Set the order ID
rsA!OrderID = lngOrder
' Use a query to find the current largest line number
Set rst = db.OpenRecordset("Select Max([LineNo]) As
MaxLine " & _
"From tblOrderProducts Where [OrderID] = " &
lngOrder)
rsA!LineNo = rst![MaxLine] + 1
rst.Close
' Set up Product ID, quantity, and prices
rsA!ProductID = lngProductID
rsA!Cost = curCost
rsA!Price = curPrice
rsA!AmtNeeded = intQuantityReq
rsA!Status = OrderStatus.None
' Save the new Order Products row with
' remaining unallocated amount
rsA.Update
' Reposition on the original line number to '
' continue processing!
rsA.FindFirst "[LineNo] = " & lngThisLine
If rsA.NoMatch Then ' Should not occur!
Error 3999
End If
End If
End If
End If
' Finished processing the current Order record - get the next
rsA.MoveNext
intI = intI + 1
' Update the status meter
varRet = SysCmd(acSysCmdUpdateMeter, intI)
Loop
' Done with all Order rows - clear the status bar
varRet = SysCmd(acSysCmdClearStatus)
' Commit what we've done
CommitTrans
intTrans = False
' Close off recordsets
rsA.Close
Set rsA = Nothing
rsI.Close
Set rsI = Nothing
rstW.Close
Set rstW = Nothing
' Turn off the hourglass
DoCmd.Hourglass False
' If got no warnings, then set up to return success
If Not (intSomeError) Then AllocateProducts = True
' If we added some Order rows
If (intAddedSome = True) Then
' If Order form loaded (it should be, but just checking)
If IsFormLoaded("frmOrders") Then
' Requery the subform
Forms!frmOrders!fsubOrderProducts.Requery
End If
End If
' See if any left unallocated - run the "append leftovers" query
Set qd = db.QueryDefs("zqappOrderProductsToOrder")
qd![OrderParm] = lngOrder
qd.Execute
' See if there are any rows
If DCount("*", "ztTblProductsToOrder") <> 0 Then
' Yes - set a flag
intSomeLeft = True
' Ask if user wants to create Purchase Orders
' But auto-create PO if called from zfrmLoadData
If intSilent Then
intDoPO = vbYes
Else
intDoPO = MsgBox("Insufficient stock in inventory for one " & _
"or more Products required for this order. " & _
"Do you want to generate purchase orders for this order?", _
vbQuestion + vbYesNo, gstrAppTitle)
End If
If intDoPO = vbYes Then
' Turn off local error trapping
On Error GoTo 0
' Call the Product PO generator - pass the silent flag
If GenProductsPO(lngOrder, intSilent, datAllocDate) Then
' Indicate Purchase Orders created
AllocateProducts = 1
intSomeLeft = False
End If
End If
End If
If (intSomeLeft = True) Then
If Not intSilent Then MsgBox "Some Products were not allocated, " &
_
"but you cancelled PO creation.", vbInformation, gstrAppTitle
End If
' Let the DBEngine catch up with all this work
DBEngine.Idle dbFreeLocks
' Done
Exit Function
AllocOrderProducts_ERR:
' Display and log any errors
If Not intSilent Then MsgBox "Unexpected Error: " & Err & _
", " & Error, vbCritical, gstrAppTitle
ErrorLog "AllocateProducts", Err, Error
On Error Resume Next
' If a transaction was started, roll it back
If (intTrans = True) Then Rollback
' Clear the status bar
varRet = SysCmd(acSysCmdClearStatus)
' Turn off the hourglass
DoCmd.Hourglass False
' Bail!
Exit Function
End Function
End Sub
"Allen Browne" <Al*********@SeeSig.Invalid> wrote in message
news:44***********************@per-qv1-newsreader-01.iinet.net.au...
We need to know a bit more about the procedure that fails.
It it includes this line:
Set rs = db.OpenRecordset("SomeTable")
try:
Set rs = db.OpenRecordset("SomeTable", dbOpenDynaset)
If that does not work, post the line that fails, and any line like the one
above.
OpenRecordset defaults to a Dynaset type for attached tables, but to a
Table type for local tables. If that is the issue, then declaring the
Dynaset type should solve the "operation is not supported for this type of
object" error.
--
Allen Browne - Microsoft MVP. Perth, Western Australia.
Tips for Access users - http://allenbrowne.com/tips.html
Reply to group, rather than allenbrowne at mvps dot org.
"royaltiger" <sg*****@ntlworld.com> wrote in message
news:yt*******************@newsfe2-win.ntli.net...I am trying to copy the inventory database in Building Access Applications
by John L Viescas but when i try to run the database i get an error in the
orders form when i click on the allocate button "Unexpected Error":3251
operation is not supported for this type of object.The demo cd has two
databases, one is called inventory and the other just has the tables for
the design called inventory data. When you run inventory the database
works fine so i thought i would use the tables in the "data" and then
import the queries and forms from the inventory, everything works fine
until i want to allocate products to a customer, i have compared tables in
both databases and they are exact except that the inventory is a linked
database, this is what i think is the problem and the table itself is the
tblInventory. Is there a few people out there who have the book and know
what i am doing wrong or know what to do to make it right
