Application.Modules do sometimes not know all modules.

I am going to make a find utility that can be used programmatically to
clean in code and table contents.

A function, modulesList() returns an array af module all names -
(standard-, class- and those of forms and reports that hasModule -
these with leading Form_ or Report_ )

My first attempt was this:

Sub findInAllModules(word)
Dim startline&, endline&, startcol&, endcol&, m
For Each m In modulesList()
If Application.Modules(m).Find(word, startline, startcol,
endline, endcol) Then
Debug.Print "found in:" & m & "at line,col=" & startline &
"," & startcol
Exit For
End If: Next
End Sub

When i run the Subroutine, sometimes Application.Modules don't seem to
know all modules - execution is stopped, the "debug/end" dialog of the
raised error appears. If i open the module code in the vba editor,
then Application.Modules suddenly knows it.

...And annoying - sometimes all modules are know by
Application.Modules

What is the vba trick to do one of the following:

*make Application.Modules know all Modules
*run vba towards a single module, that does the magick that 'open
module code in vba editor' does.
--
Benny Andersen

Benny Andersen wrote:
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

Try this:

for each md in CurrentProject.AllModules : debug.Print md.name : next


--
MGFoster:::mgf00 <at> earthlink <decimal-point> net
Oakland, CA (USA)
** Respond only to this newsgroup. I DO NOT respond to emails **

-----BEGIN PGP SIGNATURE-----
Version: PGP for Personal Privacy 5.0
Charset: noconv

iQA/AwUBSertj4echKqOuFEgEQKVBACeKtrO3X3R3yQhp31uBbLb2B g2nPgAn1G1
aZKqRCiZLVSRoZ1tMD4by1ED
=3d60
-----END PGP SIGNATURE-----

On 19 Apr., 11:23, MGFoster <m... (AT) privacy (DOT) com> wrote:
That lists every module and class module name, but not modules of
forms and reports that has class modules.
My function modulesList() returns all and works ok.
I just tried, if it has any magic effect, just to execute
CurrentProject.AllModules (and AllForms, Allreports) - it hasn't

My problems can be caught down to that the database application is in
a state, where it is impossible to open a module,
(form_formname,report_reportnmane og plain module or class module) by
executing this in immediate window:

docmd.openModule "<moduleName>"

I get an error with err.Number=7961

It is possible to open the module by dobbeltClick in project explore
window. If i keep it open in the vba editor, there isn't any problem
with running the search rutine.

I Can then close the whole database - open again and invoke the rutine
from a makro without any problem.

By the way, it is access 2000

Thanks for reply anyway
--
Benny Andersen

Benny Andersen <a.mail.user (AT) gmail (DOT) com> wrote in news:7857a738-ed68-4e91-
b433-d0aa38483d87 (AT) g37g2000yqn (...oglegroups.com:

My experience is that this procedure (SynopsisHack - below) lists all the
code in the database. It may be modifiable to give you what you want.
Note that the reference must be set with the "VBIDEReference" procedure
or interactively before the "SynopsisHack" procedure can be run.

' *** beginning of code ***

Private Const cSeparator$ = "*****"

Private Sub SynopsisHack()
' a reference to the
' MicrosoftVBIDE Type Library
' must be set.
' the Sub
' VBIDEReference
' (below)
' may effect this.
Dim pCode$
Dim pCodeModule As CodeModule
Dim pErrorNumber&
Dim pFileName$
Dim pFileNumber%
Dim pIterator0&
Dim pIterator1&
Dim pVBComponent As VBComponent
Dim pVBProject As VBProject
With VBE.VBProjects
For pIterator0 = 1 To .Count
Set pVBProject = .Item(pIterator0)
pCode = pCode & vbNewLine & cSeparator & cSeparator
pCode = pCode & vbNewLine & pVBProject.Name
pCode = pCode & vbNewLine & cSeparator & cSeparator
With pVBProject.VBComponents
For pIterator1 = 1 To .Count
Set pVBComponent = .Item(pIterator1)
Set pCodeModule = pVBComponent.CodeModule
pCode = pCode & vbNewLine & cSeparator
pCode = pCode & vbNewLine & pVBComponent.Name
pCode = pCode & vbNewLine & cSeparator
pCode = pCode & vbNewLine & pCodeModule.Lines(1,
pCodeModule.CountOfLines)
pCode = pCode & vbNewLine & cSeparator
Next pIterator1
End With
Next pIterator0
End With
pFileNumber = FreeFile
pFileName = Replace(CurrentProject.Name, ".mdb", "") & "Code.txt"
On Error Resume Next
Kill pFileName
On Error GoTo 0
Open pFileName For Binary As #pFileNumber
Put #pFileNumber, , pCode
Close #pFileNumber
Shell "NotePad " & pFileName, vbNormalFocus
End Sub

Private Sub VBIDEReference()
Const cMicrosoftVBIDETypeLibraryLocation$ = _
"C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6
\VBE6EXT.OLB"
Const cMicrosoftVBIDEGuid$ = _
"{0002E157-0000-0000-C000-000000000046}"
On Error Resume Next
With References
.AddFromGuid cMicrosoftVBIDEGuid, 5, 3
.AddFromFile cMicrosoftVBIDETypeLibraryLocation
End With
End Sub

' *** end of code ***

**************************************************
**************************************************

For Northwinds 2007 the file of code created is as follows:

**********
Northwind 2007
**********
*****
Form_Sales Reports Dialog
*****
Option Compare Database
Option Explicit


Enum SalesPeriodEnum
ByMonth = 1
ByQuarter = 2
ByYear = 3
End Enum


Sub PrintReports(ReportView As AcView)
' This procedure used in Preview_Click and Print_Click Sub
procedures.
' Preview or print report selected in the ReportToPrint option group.
' Then close the Print Sales Reports Dialog form.
Dim strReportName As String
Dim strReportFilter As String
Dim lOrderCount As Long

' Determine report filtering
If Nz(Me.lstReportFilter) <> "" Then
strReportFilter = "([SalesGroupingField] = """ &
Me.lstReportFilter & """)"
End If

' Determine reporting time frame
Select Case Me.lstSalesPeriod
Case ByYear
strReportName = "Yearly Sales Report"
lOrderCount = DCountWrapper("*", "Sales Analysis", "[Year]=" &
Me.cbYear)
Case ByQuarter
strReportName = "Quarterly Sales Report"
lOrderCount = DCountWrapper("*", "Sales Analysis", "[Year]=" &
Me.cbYear & " AND [Quarter]=" & Me.cbQuarter)
Case ByMonth
strReportName = "Monthly Sales Report"
lOrderCount = DCountWrapper("*", "Sales Analysis", "[Year]=" &
Me.cbYear & " AND [Month]=" & Me.cbMonth)
End Select

If lOrderCount > 0 Then
TempVars.Add "Group By", Me.lstSalesReports.Value
TempVars.Add "Display", DLookupStringWrapper("[Display]", "Sales
Reports", "[Group By]='" & Nz(Me.lstSalesReports) & "'")
TempVars.Add "Year", Me.cbYear.Value
TempVars.Add "Quarter", Me.cbQuarter.Value
TempVars.Add "Month", Me.cbMonth.Value

eh.TryToCloseObject
DoCmd.OpenReport strReportName, ReportView, , strReportFilter,
acWindowNormal
Else
MsgBoxOKOnly NoSalesInPeriod
End If
End Sub


Private Sub Form_Load()
SetSalesPeriod ByYear
InitFilterItems
End Sub


Sub SetSalesPeriod(SalesPeriod As SalesPeriodEnum)
Me.lstSalesPeriod = SalesPeriod
Me.cbQuarter.Enabled = (SalesPeriod = ByQuarter)
Me.cbMonth.Enabled = (SalesPeriod = ByMonth)
End Sub


Private Sub lstSalesPeriod_AfterUpdate()
SetSalesPeriod Me.lstSalesPeriod
End Sub


Private Sub lstSalesReports_AfterUpdate()
InitFilterItems
End Sub


Private Sub InitFilterItems()
Me.lstReportFilter.RowSource = DLookupStringWrapper("[Filter Row
Source]", "Sales Reports", "[Group By]='" & Nz(Me.lstSalesReports) & "'")
Me.lstReportFilter = Null
End Sub


Private Sub cmdPreview_Click()
PrintReports acViewReport
End Sub


Private Sub cmdPrint_Click()
PrintReports acViewNormal
End Sub


Private Function GetLastOrderDate() As Date
GetLastOrderDate = Nz(DMaxWrapper("[Order Date]", "Orders"), Date)
End Function
*****
*****
Form_Purchase Order Details
*****
Option Compare Database
Option Explicit


Public Function GetPurchaseDetailsSubform() As [Form_Purchases Subform
for Purchase Order Details]
Set GetPurchaseDetailsSubform = Me.sbfPurchaseDetails.Form
End Function


Private Function PurchaseContainsLineItems() As Boolean
PurchaseContainsLineItems =
Me.GetPurchaseDetailsSubform.RecordsetClone.Record Count > 0
End Function


Private Sub Supplier_ID_AfterUpdate()
Me.GetPurchaseDetailsSubform.Product_ID.Requery
Me.[Purchase Details_Page].Enabled = True
End Sub


Private Sub Supplier_ID_BeforeUpdate(Cancel As Integer)
'Changing Suppliers with defined line items requires some decisions
If PurchaseContainsLineItems() Then
If Not MsgBoxYesNo(ChangeSupplierWarning) Then
Cancel = True
ElseIf PurchaseOrder_ContainsPostedInventory() Then
MsgBoxOKOnly CannotRemovePostedItems
Cancel = True
ElseIf Not FRemovePurchaseLineItems() Then
MsgBoxOKOnly ErrorRemovingPurchaseLineItems
Cancel = True
End If
End If
End Sub


Private Sub cmdApprovePurchase_Click()
'Cannot approve purchases without line items
If Not PurchaseContainsLineItems() Then
MsgBoxOKOnly PurchaseHasNoLineItems
ElseIf Not Privileges.CanApprovePurchases() Then
MsgBoxOKOnly CannotApprovePurchases
ElseIf Not PurchaseOrders.MarkApproved(Me![Purchase Order ID]) Then
MsgBoxOKOnly PurchaseNotApproved
Else
Me.Refresh
MsgBoxOKOnly PurchaseApproved
InitFormState
End If
End Sub


Private Sub cmdCancelPurchase_Click()
If PurchaseOrder_ContainsPostedInventory() Then
MsgBoxOKOnly CannotCancelPostedOrder
ElseIf MsgBoxYesNo(CancelOrderConfirmPrompt) Then
If PurchaseOrders.Delete(Me![Purchase Order ID]) Then
MsgBoxOKOnly CancelOrderSuccess
eh.TryToGoToRecord acNewRec
Else
MsgBoxOKOnly CancelOrderFailure
End If
End If
End Sub


Private Sub cmdClose_Click()
If PurchaseOrderIsValid() Then
eh.TryToCloseObject
Else
Beep
End If
End Sub


Private Sub cmdSubmitforApproval_Click()
'Cannot submit purchases without line items
If Not PurchaseContainsLineItems() Then
MsgBoxOKOnly PurchaseHasNoLineItems
Else
Me.Submitted_By = GetCurrentUserID()
Me.Submitted_Date = Date
Me![Status ID] = Submitted_PurchaseOrder
eh.TryToSaveRecord 'Refresh joined data
MsgBoxOKOnly PurchaseSubmitted
InitFormState
End If
End Sub


Private Sub Form_Current()
InitFormState
End Sub


Private Sub TabCtlPurchasing_Change()
Select Case Me.TabCtlPurchasing.Value
Case Me.[Purchase Details_Page].PageIndex
Me.[Purchase Details_Page].Requery
Case Me.[Payment Information_Page].PageIndex
Me.[Inventory Receiving_Page].Requery
End Select
End Sub


Private Function FRemovePurchaseLineItems() As Boolean
'Don't allow removal for purchases with posted line items
If Not PurchaseOrder_ContainsPostedInventory() Then

Dim rsw As New RecordsetWrapper
With rsw.GetRecordsetClone
(Me.GetPurchaseDetailsSubform.Recordset)
While Not .EOF
If Not ![Posted To Inventory] And IsNull(![Inventory ID])
Then
rsw.Delete
End If
rsw.MoveNext
Wend
End With

Me.GetPurchaseDetailsSubform.Requery
FRemovePurchaseLineItems = True
End If
End Function


Private Function PurchaseOrder_ContainsPostedInventory() As Boolean
Dim rsw As New RecordsetWrapper
With rsw.GetRecordsetClone(Me.GetPurchaseDetailsSubform .Recordset)
While Not .EOF
If ![Posted To Inventory] And Not IsNull(![Inventory ID])
Then
PurchaseOrder_ContainsPostedInventory = True
Exit Function
End If
rsw.MoveNext
Wend
End With
End Function


Function PurchaseOrderIsValid() As Boolean
Dim PurchaseOrderID As Long
PurchaseOrderID = Nz(Me![Purchase Order ID], 0)

Select Case Me![Status ID]
Case New_PurchaseOrder
If Not PurchaseContainsLineItems() Then
MsgBoxOKOnly PurchaseHasNoLineItems
If MsgBoxYesNo(CancelOrderPrompt) Then
If PurchaseOrders.Exists(PurchaseOrderID) Then
If Not PurchaseOrders.Delete(PurchaseOrderID) Then
Exit Function
End If
End If
End If
End If
Case Submitted_PurchaseOrder
Case Approved_PurchaseOrder
Case Closed_PurchaseOrder
End Select

PurchaseOrderIsValid = True
End Function


Public Sub InitFormState()
Dim Status As PurchaseOrderStatusEnum

Me.Supplier_ID.SetFocus

Status = Nz(Me![Status ID], New_PurchaseOrder)

Me.cmdSubmitforApproval.Enabled = (Status = New_PurchaseOrder)
Me.cmdApprovePurchase.Enabled = (Status = Submitted_PurchaseOrder)
Me.cmdCancelPurchase.Enabled = (Status <> New_PurchaseOrder)

If IsNull(Me![Supplier ID]) Then
Me.[Purchase Details_Page].Enabled = False
Else
Me.[Purchase Details_Page].Enabled = (Status = New_PurchaseOrder)
Or (Status = Submitted_PurchaseOrder)
End If

Me.[Inventory Receiving_Page].Enabled = (Status =
Approved_PurchaseOrder)
Me.[Payment Information_Page].Enabled = (Status =
Approved_PurchaseOrder)

Me.AllowEdits = Not (Status = Closed_PurchaseOrder)
Me.AllowDeletions = Not (Status = Closed_PurchaseOrder)
End Sub
*****
*****
Utilities
*****
Option Compare Database
Option Explicit

Public eh As New ErrorHandling

Public Enum StringIDEnum
AppTitle = 2
CannotRemovePostedInventory = 3
FilledBackOrderedProduct = 4
DiscountedPriceBelowCost = 5
InsufficientInventory = 6
NoInventoryCreatePO = 7
PurchaseOrdersCreated = 8
NoProductsBelowReorderLevels = 9
MustSpecifyCustomer = 10
RestockAllInventory = 11
CannotCreatePO_NoSupplier = 12
PriceBelowCost = 13
WantToContinue = 14
OrderAlreadyInvoiced = 15
OrderDoesNotContainLineItems = 16
MustBeAllocatedBeforeInvoicing = 17
NoSalesInPeriod = 18
RestockSuccess = 19
NoNeedToRestock = 21
RestockingFailed = 22
InvalidLogin = 23
MustFirstSelectReport = 24
ChangeSupplierWarning = 25
RestockingSummary = 26
RestockingError = 27
RestockingDetails = 28
CannotRemovePostedItems = 29
ErrorRemovingPurchaseLineItems = 30
CannotModifyPurchaseQuantity = 31
CannotModifyPurchasePrice = 32
InventoryPostingSuccess = 33
InventoryPostingFailure = 34
FillBackOrdersPrompt = 35
CannotPostNoReceivedDate = 36
PostReceivedProductPrompt = 37
InitializeAppData = 38
MustSpecifyEmployeeName = 39
MustBeLoggedInToApprovePurchase = 40
CannotApprovePurchaseWithoutLineItems = 41
CannotApprovePurchases = 42
PurchaseApproved = 43
PurchaseNotApproved = 44
PurchaseSubmitted = 45
PurchaseNotSubmitted = 46
PurchaseHasNoLineItems = 47
CancelOrderPrompt = 48
CancelOrderConfirmPrompt = 49
CancelOrderSuccess = 100
CannotCancelPostedOrder = 101
CancelOrderFailure = 102
OrderIsNotInvoiced = 103
ShippingNotComplete = 104
CannotShipNotInvoiced = 105
CannotCancelShippedOrder = 106
MustSpecifySalesPerson = 107
OrderMarkedClosed = 108
OrderMustBeShippedToClose = 109
PaymentInfoNotComplete = 110
ErrorAttemptingToRestock = 111
NeedUnitCost = 112
FillBackOrderedProduct = 113
PurchaseGeneratedBasedOnOrder = 114
End Enum


Function MsgBoxYesNo(StringID As StringIDEnum, Optional ByVal strInsert
As String) As Boolean
MsgBoxYesNo = vbYes = MsgBoxID(StringID, vbYesNo, strInsert)
End Function


Sub MsgBoxOKOnly(StringID As StringIDEnum, Optional ByVal strInsert As
String)
MsgBoxID StringID, vbOKOnly, strInsert
End Sub


Function MsgBoxID(StringID As StringIDEnum, Buttons As VbMsgBoxStyle,
Optional ByVal strInsert As String) As VbMsgBoxResult
MsgBoxID = MsgBox(InsertString(StringID, strInsert), Buttons,
LoadString(AppTitle))
End Function


Function LoadString(StringID As StringIDEnum) As String
LoadString = DLookupStringWrapper("[String Data]", "Strings",
"[String ID]=" & StringID)

' Verify that the specified string was found using
DLookupStringWrapper.
' If you hit this breakpoint, verify that the StringID exists in the
Strings table.
Debug.Assert LoadString <> ""
End Function


Function InsertString(StringID As StringIDEnum, strInsert As String) As
String
InsertString = Replace(LoadString(StringID), "|", strInsert)
End Function


Function HasSourceCode() As Boolean
On Error Resume Next
HasSourceCode = (CurrentDb.Properties("MDE") <> "T")
' Property not found error
If Err = 3270 Then HasSourceCode = True
On Error GoTo 0
End Function


Function IsRuntime() As Boolean
IsRuntime = SysCmd(acSysCmdRuntime)
End Function


Function DebuggingSupported() As Boolean
DebuggingSupported = HasSourceCode() And Not IsRuntime()
End Function
*****
*****
Form_Order Subform for Order Details
*****
Option Compare Database
Option Explicit


Private Sub Product_ID_AfterUpdate()
'Initialize price and discount for each product change
If Not IsNull(Me![Product ID]) Then
Me![Quantity] = 0
Me.Quantity.Locked = False
Me![Unit Price] = GetListPrice(Me![Product ID])
Me![Discount] = 0
Me![Status ID] = None_OrderItemStatus


'Empty Product records mean user wants to delete line item
Else
eh.TryToRunCommand acCmdDeleteRecord
End If
End Sub


Private Sub Form_Current()
If Nz(Me![Status ID], None_OrderItemStatus) =
Invoiced_OrderItemStatus Then
Me.AllowEdits = False
Else
Me.AllowEdits = True
End If
End Sub


Private Sub Quantity_AfterUpdate()
On Error GoTo ErrorHandler

Dim IT As InventoryTransaction
Dim PurchaseOrderID As Long
Dim SupplierID As Long

IT.ProductID = Nz(Me![Product ID], 0)
IT.Quantity = Me![Quantity]
IT.AllOrNothing = True
IT.InventoryID = Nz(Me![Inventory ID], NewInventoryID)

'Request Hold on specified Inventory
If Inventory.RequestHold(Me![Order ID], IT) Then
Me![Inventory ID] = IT.InventoryID
Me![Status ID] = OnHold_OrderItemStatus

'Insufficient Inventory
ElseIf Me![Status ID] <> None_OrderItemStatus And Me![Status ID] <>
NoStock_OrderItemStatus Then
MsgBoxOKOnly InsufficientInventory
Me![Quantity] = Me.Quantity.OldValue

'Attempt to create purchase order for back ordered items
ElseIf MsgBoxYesNo(NoInventoryCreatePO) Then

SupplierID = Inventory.FindProductSupplier(IT.ProductID)

'Create purchase order if we have supplier for this product
If SupplierID > 0 Then
If PurchaseOrders.Generate(SupplierID, IT.ProductID, Me!
[Quantity], Me![Order ID], PurchaseOrderID) Then
PurchaseOrders.OpenOrder PurchaseOrderID
Me![Status ID] = OnOrder_OrderItemStatus
Me![Purchase Order ID] = PurchaseOrderID
eh.TryToSaveRecord
Else
Me![Status ID] = NoStock_OrderItemStatus
End If

'Could not find a supplier for this product
Else
MsgBoxOKOnly CannotCreatePO_NoSupplier
Me![Status ID] = NoStock_OrderItemStatus
End If

Else
Me![Status ID] = NoStock_OrderItemStatus
End If

Done:
Exit Sub

ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("Quantity_AfterUpdate") Then Resume
End Sub


Private Sub Status_Name_DblClick(Cancel As Integer)
Select Case Me![Status ID]
Case NoStock_OrderItemStatus, None_OrderItemStatus
Quantity_AfterUpdate
Case OnOrder_OrderItemStatus
Dim PurchaseOrderID As Long
PurchaseOrderID = Nz(Me![Purchase Order ID], 0)
If PurchaseOrderID > 0 Then
PurchaseOrders.OpenOrder PurchaseOrderID
Me.Requery
End If
Case Invoiced_OrderItemStatus
End Select
End Sub
*****
*****
ErrorHandling
*****
Option Compare Database
Option Explicit

Public Function LogError(strLocation As String, ParamArray State()) As
Boolean
Dim strMsg As String
Dim strState As String

' Build the error message to display
strMsg = Err.Description & " (" & Err.Number & ")" & vbCrLf & vbCrLf
& strLocation

strState = Join(State, vbCrLf)

If strState <> "" Then
strMsg = strMsg & vbCrLf & vbCrLf & strState
End If

' Display the error
MsgBox strMsg, vbCritical

' If debugging is supported, break using Debug.Assert.
If DebuggingSupported() Then
Debug.Assert False ' Stop code so that you can debug
LogError = True ' Step over this line if you don't want to
resume
End If
End Function


Function TryToCloseObject() As Boolean
On Error GoTo ErrorHandler

DoCmd.Close
TryToCloseObject = True

Done:
Exit Function
ErrorHandler:
MsgBox Err.Description
Resume Done
End Function


Function TryToSaveRecord() As Boolean
TryToSaveRecord = TryToRunCommand(acCmdSaveRecord)
End Function


Function TryToRunCommand(Command As AcCommand) As Boolean
On Error GoTo ErrorHandler

DoCmd.RunCommand Command
TryToRunCommand = True

Done:
Exit Function
ErrorHandler:
MsgBox Err.Description
Resume Done
End Function


Function TryToGoToRecord(Record As AcRecord) As Boolean
On Error GoTo ErrorHandler

DoCmd.GoToRecord , , Record

Done:
Exit Function
ErrorHandler:
MsgBox Err.Description
Resume Done
End Function
*****
*****
CustomerOrders
*****
Option Compare Database
Option Explicit

Public Enum CustomerOrderStatusEnum
New_CustomerOrder = 0
Invoiced_CustomerOrder = 1
Shipped_CustomerOrder = 2
Closed_CustomerOrder = 3
End Enum


Function CreateInvoice(OrderID As Long, Amt As Currency, InvoiceID As
Long) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Invoices") Then
With rsw.Recordset
If Not rsw.AddNew Then Exit Function
![Order ID] = OrderID
![Amount Due] = Amt
If rsw.Update Then
.Bookmark = .LastModified
InvoiceID = ![Invoice ID]
CreateInvoice = True
End If
End With
End If
End Function


Function IsInvoiced(OrderID As Long) As Boolean
IsInvoiced = DCountWrapper("[Invoice ID]", "Invoices", "[Order ID]="
& OrderID) > 0
End Function


Function PrintInvoice(OrderID As Long) As Boolean
DoCmd.OpenReport "Invoice", acViewPreview, , "[Order ID]=" & OrderID,
acDialog
End Function


Function SetStatus(OrderID As Long, Status As CustomerOrderStatusEnum) As
Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Orders", "[Order ID] = " & OrderID) Then
With rsw.Recordset
If Not .EOF Then
.Edit
![Status ID] = Status
SetStatus = rsw.Update
End If
End With
End If
End Function


Function Delete(OrderID As Long) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Orders", "[Order ID] = " & OrderID) Then
Delete = rsw.Delete
End If
End Function
*****
*****
Form_Inventory List
*****
Option Compare Database
Option Explicit

Private Sub cmdPurchase_Click()
If Not Me![Qty To Reorder] > 0 Then
MsgBoxOKOnly NoNeedToRestock
ElseIf Inventory.RestockProduct(Me![Product ID]) Then
Me.Requery
MsgBoxOKOnly RestockSuccess
Else
MsgBoxOKOnly RestockingFailed
End If
End Sub
*****
*****
Report_Yearly Sales Report
*****
Option Compare Database
Option Explicit


Private Sub Report_Open(Cancel As Integer)
On Error GoTo ErrorHandler

Dim strSQL As String

If IsNull(TempVars![Display]) Or IsNull(TempVars![Group By]) Or
IsNull(TempVars![Year]) Then
DoCmd.OpenForm "Sales Reports Dialog"
Cancel = True
Exit Sub
End If

strSQL = "TRANSFORM CCur(Nz(Sum([Sales]),0)) AS X"
strSQL = strSQL & " SELECT [" & TempVars![Display] & "] as
SalesGroupingField FROM [Sales Analysis] "
strSQL = strSQL & " Where [Year]=" & TempVars![Year]
strSQL = strSQL & " GROUP BY [" & TempVars![Group By] & "], [" &
TempVars![Display] & "]"
strSQL = strSQL & " Pivot [Sales Analysis].[Quarter] In (1,2,3,4)"

Me.RecordSource = strSQL
Me.SalesGroupingField_Label.Caption = TempVars![Display]

Done:
Exit Sub
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("Yearly Sales Report_Open", "strSQL = " & strSQL) Then
Resume
Else
Cancel = True
End If
End Sub
*****
*****
Report_Quarterly Sales Report
*****
Option Compare Database
Option Explicit

Private Sub Report_Open(Cancel As Integer)
On Error GoTo ErrorHandler
Dim strSQL As String

If IsNull(TempVars![Display]) Or IsNull(TempVars![Year]) Or IsNull
(TempVars![Quarter]) Or IsNull(TempVars![Group By]) Then
DoCmd.OpenForm "Sales Reports Dialog"
Cancel = True
Exit Sub
End If

strSQL = "TRANSFORM CCur(Nz(Sum([Sales]),0)) AS X"
strSQL = strSQL & " SELECT [" & TempVars![Display] & "] as
SalesGroupingField FROM [Sales Analysis] "
strSQL = strSQL & " Where [Quarter]=" & TempVars![Quarter] & " AND
[Year]=" & TempVars![Year]
strSQL = strSQL & " GROUP BY [" & TempVars![Group By] & "], [" &
TempVars![Display] & "]"
strSQL = strSQL & " Pivot [Sales Analysis].[MonthOfQuarter] In
(1,2,3)"

Me.RecordSource = strSQL
Me.SalesGroupingField_Label.Caption = TempVars![Display]

Dim iMonth As Integer
Dim iStartMonth As Integer
Dim iEndMonth As Integer
iStartMonth = ((TempVars![Quarter] - 1) * 3) + 1
iEndMonth = iStartMonth + 2
For iMonth = iStartMonth To iEndMonth
Me.Controls((iMonth - iStartMonth + 1) & "_Label").Caption =
Format(DateSerial(2005, iMonth, 1), "mmm")
Next iMonth

Done:
Exit Sub
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("Quarterly Sales Report_Open", "strSQL = " & strSQL)
Then
Resume
Else
Cancel = True
End If
End Sub
*****
*****
Inventory
*****
Option Compare Database
Option Explicit

Public Enum InventoryTransactionTypeEnum
Purchase_TransactionType = 1
Sold_TransactionType = 2
Hold_TransactionType = 3
End Enum

Type InventoryTransaction
ProductID As Long 'Product being added or removed to
inventory
TransactionType As InventoryTransactionTypeEnum '1=Purchase; 2
=Sale; 3=Hold; 4=Waste;
Quantity As Long 'Quanitity specifed for purchase,
sale, hold, etc.
QuantityGranted As Long 'Actual Quanity Granted; may be less
than specfied
InventoryID As Long 'Inventory Transaction ID returned to
the caller
AllOrNothing As Boolean 'All or nothing flag for product
allocations
Comments As String
End Type

Public Enum OrderItemStatusEnum
None_OrderItemStatus = 0
OnHold_OrderItemStatus = 1
Invoiced_OrderItemStatus = 2
Shipped_OrderItemStatus = 3
OnOrder_OrderItemStatus = 4
NoStock_OrderItemStatus = 5
End Enum

Private Const m_cNew_InventoryID = -1


Public Property Get NewInventoryID() As Long
NewInventoryID = m_cNew_InventoryID
End Property


Function AddPurchase(PurchaseOrderID As Long, ProductID As Long, Qty As
Long, ByRef InventoryID As Long) As Boolean
Dim IT As InventoryTransaction

IT.TransactionType = Purchase_TransactionType
IT.ProductID = ProductID
IT.Quantity = Qty
IT.InventoryID = m_cNew_InventoryID

If EditTransaction(IT, , PurchaseOrderID) Then
AddPurchase = True
InventoryID = IT.InventoryID
End If
End Function


Function RemovePurchase(lInventoryID As Long)
MsgBoxOKOnly CannotRemovePostedInventory
End Function


Function GetQtyAvailable(ProductID As Long) As Long
GetQtyAvailable = GetInventoryQuantity("[Qty Available]", ProductID)
End Function


Function GetQtyOnHand(ProductID As Long) As Long
GetQtyOnHand = GetInventoryQuantity("[Qty On Hand]", ProductID)
End Function


Function GetQtyToReorder(ProductID As Long) As Long
GetQtyToReorder = GetInventoryQuantity("[Qty To Reorder]", ProductID)
End Function


Function GetQtyOnBackOrder(ProductID As Long) As Long
GetQtyOnBackOrder = GetInventoryQuantity("[Qty On Back Order]",
ProductID)
End Function


Private Function GetInventoryQuantity(FieldName As String, ProductID As
Long) As Long
GetInventoryQuantity = DLookupNumberWrapper(FieldName, "Inventory",
"[Product ID] = " & ProductID)
End Function


Function RequestHold(OrderID As Long, IT As InventoryTransaction) As
Boolean

IT.TransactionType = Hold_TransactionType

If (IT.InventoryID = m_cNew_InventoryID) Then
RequestHold = AddHold(OrderID, IT)
Else
RequestHold = ModifyHold(IT)
End If

End Function


Function AddHold(OrderID As Long, IT As InventoryTransaction) As Boolean
Dim QtyAvailable As Long
Dim QtyToHold As Long
Dim QtyRequested As Long

' Intialize Inventory quantities
QtyAvailable = GetQtyAvailable(IT.ProductID)
QtyRequested = IT.Quantity
QtyToHold = 0

' Check if we have sufficient Inventory
If QtyRequested > QtyAvailable Then
If Not IT.AllOrNothing Then
QtyToHold = QtyAvailable
End If
Else
QtyToHold = QtyRequested
End If

' Execute the Hold
If QtyToHold > 0 Then
IT.TransactionType = Hold_TransactionType
IT.Quantity = QtyToHold
AddHold = EditTransaction(IT, OrderID)
IT.Quantity = QtyRequested
Else
IT.QuantityGranted = 0
End If

End Function


Function ModifyHold(IT As InventoryTransaction) As Boolean
Dim ChangeInQuantity As Long
Dim IT_Existing As InventoryTransaction

' Get Information on Previous Hold
IT_Existing.InventoryID = IT.InventoryID
If GetTransaction(IT_Existing) Then
ChangeInQuantity = IT.Quantity - IT_Existing.Quantity

' Determine if we have sufficient Inventory to increase Hold
If ChangeInQuantity < 0 Or ChangeInQuantity < GetQtyAvailable
(IT.ProductID) Then
IT.Quantity = IT.Quantity
If EditTransaction(IT) Then
IT.QuantityGranted = IT.Quantity
ModifyHold = True
Else
IT.QuantityGranted = IT_Existing.Quantity
End If
End If
End If

End Function


Function HoldToSold(InventoryID As Long) As Boolean
Dim IT As InventoryTransaction

IT.InventoryID = InventoryID
If GetTransaction(IT) Then
IT.TransactionType = Sold_TransactionType
If EditTransaction(IT) Then
HoldToSold = True
End If
End If
End Function


Function RemoveHold(InventoryID As Long) As Boolean
RemoveHold = DeleteTransaction(InventoryID)
End Function


Function GetTransaction(IT As InventoryTransaction) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Inventory Transactions", "[Transaction ID] = "
& IT.InventoryID) Then
With rsw.Recordset
If Not .EOF Then
IT.ProductID = ![Product ID]
IT.Quantity = ![Quantity]
IT.TransactionType = ![Transaction Type]
IT.Comments = Nz(![Comments])
GetTransaction = True
End If
End With
End If
End Function


Function EditTransaction(IT As InventoryTransaction, Optional
CustomerOrderID, Optional PurchaseOrderID) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Inventory Transactions", "[Transaction ID] = "
& IT.InventoryID) Then
With rsw.Recordset
If IT.TransactionType <= 0 Then
Exit Function
ElseIf IT.InventoryID = m_cNew_InventoryID Then
rsw.AddNew
ElseIf .EOF Then
Exit Function
Else
rsw.Edit
![Transaction Modified Date] = Now()
End If

![Product ID] = IT.ProductID
![Quantity] = IT.Quantity
![Transaction Type] = IT.TransactionType
![Comments] = IIf(IT.Comments = "", Null, IT.Comments)
If Not IsMissing(CustomerOrderID) Then ![Customer Order ID] =
CustomerOrderID
If Not IsMissing(PurchaseOrderID) Then ![Purchase Order ID] =
PurchaseOrderID
EditTransaction = rsw.Update

If IT.InventoryID = m_cNew_InventoryID Then
rsw.Recordset.Bookmark = rsw.Recordset.LastModified
IT.InventoryID = ![Transaction ID]
End If
End With
End If
End Function


Function DeleteTransaction(InventoryID As Long) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Inventory Transactions", "[Transaction ID] = "
& InventoryID) Then
DeleteTransaction = rsw.Delete
End If
End Function


Function RestockProduct(ProductID As Long) As Boolean
Dim SupplierID As Long
Dim QtyToOrder As Long
Dim PurchaseOrderID As Long
Dim UnitCost As Long

QtyToOrder = GetQtyToReorder(ProductID)

If QtyToOrder > 0 Then

SupplierID = FindProductSupplier(ProductID)

If SupplierID > 0 Then

' Generate new Purchase Order if necessary
If PurchaseOrderID = 0 Then
If Not PurchaseOrders.Create(SupplierID, GetCurrentUserID
(), -1, PurchaseOrderID) Then
Exit Function
End If
End If

' Set unit cost to standard cost for product
UnitCost = GetStandardCost(Nz(ProductID, 0))

' Add product line item to Purchase Order
If Not PurchaseOrders.CreateLineItem(PurchaseOrderID,
ProductID, UnitCost, QtyToOrder) Then
Exit Function
End If

Else
' Suggested Enhancement: Handle case where product does not
have a supplier
End If

End If

RestockProduct = True
End Function


Function FindProductSupplier(ProductID As Long) As Long
FindProductSupplier = DLookupNumberWrapper("[Supplier IDs].Value",
"Products", "[ID]=" & ProductID)
End Function


Function GetRestockingPurchaseOrder(SupplierID) As Long
GetRestockingPurchaseOrder = DLookupNumberWrapper("[Purchase Order
ID]", "Purchase Orders", "[Supplier ID]=" & SupplierID & " AND [Status
ID] < 2")
End Function


Function FillBackOrders(ProductID) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Order Details", "[Product ID] =" & ProductID &
" AND [Status ID] = " & OnOrder_OrderItemStatus) Then
With rsw.Recordset
Dim IT As InventoryTransaction
While Not .EOF
' Back Order Products should not be associated with any
Inventory at this point
If IsNull(![Inventory ID]) Then
IT.Quantity = ![Quantity]
IT.ProductID = ![Product ID]
IT.InventoryID = m_cNew_InventoryID

If FillBackOrder(![Order ID], IT) Then
.Edit
![Status ID] = OnHold_OrderItemStatus
![Inventory ID] = IT.InventoryID
.Update
MsgBoxOKOnly FilledBackOrderedProduct, ![Order
ID]
End If
End If

rsw.MoveNext
Wend
End With
FillBackOrders = True
End If
End Function


Function FillBackOrder(OrderID As Long, IT As InventoryTransaction) As
Boolean
IT.TransactionType = Hold_TransactionType
IT.Comments = InsertString(FillBackOrderedProduct, CStr(OrderID))

If GetQtyAvailable(IT.ProductID) >= IT.Quantity Then
FillBackOrder = EditTransaction(IT)
End If
End Function
*****
*****
Form_Receiving Subform for Purchase Order Details
*****
Option Compare Database
Option Explicit


Private Sub Posted_To_Inventory_AfterUpdate()
On Error GoTo ErrorHandler

Dim InventoryID As Long
Dim ProductID As Long
Dim Quantity As Long

ProductID = Nz(Me![Product ID], 0)
Quantity = Nz(Me![Quantity], 0)
InventoryID = Nz(Me![Inventory ID], 0)

'Posting New Inventory
If Me![Posted To Inventory] Then
If IsNull(Me![Date Received]) Then
Me![Date Received] = Date
End If

If Inventory.AddPurchase(Me![Purchase Order ID], ProductID,
Quantity, InventoryID) Then
If InventoryID > 0 Then
Me![Inventory ID] = InventoryID
Me![Posted To Inventory] = True
MsgBoxOKOnly InventoryPostingSuccess
End If
Else
Me![Posted To Inventory] = False
MsgBoxOKOnly InventoryPostingFailure
End If

eh.TryToSaveRecord

If Inventory.GetQtyOnBackOrder(ProductID) > 0 Then
If MsgBoxYesNo(FillBackOrdersPrompt) Then
Inventory.FillBackOrders ProductID
End If
End If

'Removing Posted Inventory
Else
If InventoryID > 0 Then
Me![Posted To Inventory] = True
End If
End If

Done:
Exit Sub

ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("Posted_To_Inventory_AfterUpdate") Then Resume
End Sub


Private Sub Date_Received_AfterUpdate()
If Me![Posted To Inventory] Then
Debug.Assert False
ElseIf MsgBoxYesNo(PostReceivedProductPrompt) Then
Me![Posted To Inventory] = True
Posted_To_Inventory_AfterUpdate
End If
End Sub


Private Sub Form_Current()
Me.AllowEdits = Not Me![Posted To Inventory]
End Sub


Private Sub Form_Load()
Dim rsw As New RecordsetWrapper
With rsw.GetRecordsetClone(Me.Recordset)
'Ensure integrity of Inventory postings
While Not .EOF
If Not IsNull(![Inventory ID]) Then
rsw.Edit
![Posted To Inventory] = True
rsw.Update
End If
rsw.MoveNext
Wend
End With
End Sub
*****
*****
Privileges
*****
Option Compare Database
Option Explicit

Public Enum PrivilegeEnum
Administrator_Privilege = 1
PurchaseApprovals_Privilege = 2
End Enum

Private Function EmployeeHas(EmployeeID As Long, PrivilegeID As
PrivilegeEnum) As Boolean
EmployeeHas = DCountWrapper("*", "Employee Privileges", "[Employee
ID]=" & EmployeeID & " AND [Privilege ID]=" & PrivilegeID) > 0
End Function

Public Function CanApprovePurchases() As Boolean

CanApprovePurchases = EmployeeHas(GetCurrentUserID(),
PurchaseApprovals_Privilege)

End Function

Public Function IsAdministrator() As Boolean

IsAdministrator = EmployeeHas(GetCurrentUserID(),
Administrator_Privilege)

End Function

Public Function GetCurrentUserID() As Long
GetCurrentUserID = Nz(TempVars![CurrentUserID], 0)
End Function
*****
*****
Form_Order Details
*****
Option Compare Database
Option Explicit


Sub SetDefaultShippingAddress()
If IsNull(Me![Customer ID]) Then
ClearShippingAddress
Else

Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Customers Extended", "[ID] = " &
Me.Customer_ID) Then
With rsw.Recordset
Me![Ship Name] = ![Contact Name]
Me![Ship Address] = ![Address]
Me![Ship City] = ![City]
Me![Ship State/Province] = ![State/Province]
Me![Ship ZIP/Postal Code] = ![ZIP/Postal Code]
Me![Ship Country/Region] = ![Country/Region]
End With
End If
End If
End Sub


Private Sub cmdDeleteOrder_Click()
If IsNull(Me![Order ID]) Then
Beep
ElseIf Me![Status ID] = Shipped_CustomerOrder Or Me![Status ID] =
Closed_CustomerOrder Then
MsgBoxOKOnly CannotCancelShippedOrder
ElseIf MsgBoxYesNo(CancelOrderConfirmPrompt) Then
If CustomerOrders.Delete(Me![Order ID]) Then
MsgBoxOKOnly CancelOrderSuccess
eh.TryToCloseObject
Else
MsgBoxOKOnly CancelOrderFailure
End If
End If
End Sub


Private Sub cmdClearAddress_Click()
ClearShippingAddress
End Sub


Private Sub ClearShippingAddress()
Me![Ship Name] = Null
Me![Ship Address] = Null
Me![Ship City] = Null
Me![Ship State/Province] = Null
Me![Ship ZIP/Postal Code] = Null
Me![Ship Country/Region] = Null
End Sub


Private Sub cmdCompleteOrder_Click()
If Me![Status ID] <> Shipped_CustomerOrder Then
MsgBoxOKOnly OrderMustBeShippedToClose
ElseIf ValidateOrder(Closed_CustomerOrder) Then
Me![Status ID] = Closed_CustomerOrder
eh.TryToSaveRecord
MsgBoxOKOnly OrderMarkedClosed
SetFormState
End If
End Sub


Private Sub cmdCreateInvoice_Click()
Dim OrderID As Long
Dim InvoiceID As Long

OrderID = Nz(Me![Order ID], 0)

' Gracefully exit if invoice already created
If CustomerOrders.IsInvoiced(OrderID) Then
If MsgBoxYesNo(OrderAlreadyInvoiced) Then
CustomerOrders.PrintInvoice OrderID
End If
ElseIf ValidateOrder(Invoiced_CustomerOrder) Then

' Create Invoice Record
If CustomerOrders.CreateInvoice(OrderID, 0, InvoiceID) Then

' Mark all Order Items Invoiced
' Need to change Inventory Status to SOLD from HOLD
Dim rsw As New RecordsetWrapper
With rsw.GetRecordsetClone(Me.sbfOrderDetails.Form.Reco rdset)
While Not .EOF
If Not IsNull(![Inventory ID]) And ![Status ID] =
OnHold_OrderItemStatus Then
rsw.Edit
![Status ID] = Invoiced_OrderItemStatus
rsw.Update
Inventory.HoldToSold ![Inventory ID]
End If
rsw.MoveNext
Wend
End With

' Print the Invoice
CustomerOrders.PrintInvoice OrderID

SetFormState
End If
End If
End Sub


Private Sub cmdShipOrder_Click()
If Not CustomerOrders.IsInvoiced(Nz(Me![Order ID], 0)) Then
MsgBoxOKOnly CannotShipNotInvoiced
ElseIf Not ValidateShipping() Then
MsgBoxOKOnly ShippingNotComplete
Else
Me![Status ID] = Shipped_CustomerOrder

If IsNull(Me![Shipped Date]) Then
Me![Shipped Date] = Date
End If
eh.TryToSaveRecord
SetFormState
End If
End Sub


Private Sub Customer_ID_AfterUpdate()
SetFormState False
If Not IsNull(Me![Customer ID]) Then
SetDefaultShippingAddress
End If
End Sub

Private Sub Form_Current()
SetFormState
End Sub


Private Sub Form_Load()
SetFormState
End Sub


Function GetDefaultSalesPersonID() As Long
GetDefaultSalesPersonID = GetCurrentUserID()
End Function


Function ValidateShipping() As Boolean
If IsNull(Me![Shipper ID]) Then Exit Function
If Nz(Me![Ship Name]) = "" Then Exit Function
If Nz(Me![Ship Address]) = "" Then Exit Function
If Nz(Me![Ship City]) = "" Then Exit Function
If Nz(Me![Ship State/Province]) = "" Then Exit Function
If Nz(Me![Ship ZIP/Postal Code]) = "" Then Exit Function

ValidateShipping = True
End Function


Function ValidatePaymentInfo() As Boolean
If IsNull(Me![Payment Type]) Then Exit Function
If IsNull(Me![Paid Date]) Then Exit Function

ValidatePaymentInfo = True
End Function


Sub SetFormState(Optional fChangeFocus As Boolean = True)
If fChangeFocus Then Me.Customer_ID.SetFocus

Dim Status As CustomerOrderStatusEnum

Status = Nz(Me![Status ID], New_CustomerOrder)

TabCtlOrderData.Enabled = Not IsNull(Me![Customer ID])

Me.cmdCreateInvoice.Enabled = (Status = New_CustomerOrder)
Me.cmdShipOrder.Enabled = (Status = New_CustomerOrder) Or (Status =
Invoiced_CustomerOrder)
Me.cmdDeleteOrder.Enabled = (Status = New_CustomerOrder) Or (Status =
Invoiced_CustomerOrder)
Me.cmdCompleteOrder.Enabled = (Status <> Closed_CustomerOrder)

Me.[Order Details_Page].Enabled = (Status = New_CustomerOrder)
Me.[Shipping Information_Page].Enabled = (Status = New_CustomerOrder)
Me.[Payment Information_Page].Enabled = (Status <>
Closed_CustomerOrder)

Me.Customer_ID.Locked = (Status <> New_CustomerOrder)
Me.Employee_ID.Locked = (Status <> New_CustomerOrder)

Me.sbfOrderDetails.Locked = (Status <> New_CustomerOrder)
End Sub


Function ValidateOrder(Validation_OrderStatus As CustomerOrderStatusEnum)
As Boolean
If IsNull(Me![Customer ID]) Then
MsgBoxOKOnly MustSpecifyCustomer
ElseIf IsNull(Me![Employee ID]) Then
MsgBoxOKOnly MustSpecifySalesPerson
ElseIf Not ValidateShipping() Then
MsgBoxOKOnly ShippingNotComplete
Else
If Validation_OrderStatus = Closed_CustomerOrder Then
If Not ValidatePaymentInfo() Then
MsgBoxOKOnly PaymentInfoNotComplete
Exit Function
End If
End If

Dim rsw As New RecordsetWrapper
With rsw.GetRecordsetClone(Me.sbfOrderDetails.Form.Reco rdset)
' Check that we have at least one specified line items
If .RecordCount = 0 Then
MsgBoxOKOnly OrderDoesNotContainLineItems
Else
' Check all that all line items have allocated inventory
Dim LineItemCount As Integer
Dim Status As OrderItemStatusEnum
LineItemCount = 0
While Not .EOF
LineItemCount = LineItemCount + 1
Status = Nz(![Status ID], None_OrderItemStatus)
If Status <> OnHold_OrderItemStatus And Status <>
Invoiced_OrderItemStatus Then
MsgBoxOKOnly MustBeAllocatedBeforeInvoicing
Exit Function
End If
rsw.MoveNext
Wend

ValidateOrder = True
End If
End With
End If
End Function
*****
*****
DomainFunctionWrappers
*****
Option Compare Database
Option Explicit

Private Enum DomainFunctionWrapperEnum
DLookup_Wrapper
DCount_Wrapper
DSum_Wrapper
DMax_Wrapper
DMin_Wrapper
DAvg_Wrapper
End Enum

Private Function DomainFunctionWrapper(DomainFunction As
DomainFunctionWrapperEnum, _
Expr As String, _
Domain As String, _
Optional Criteria As String) As
Variant
On Error GoTo ErrorHandler

Select Case DomainFunction
Case DLookup_Wrapper
DomainFunctionWrapper = DLookup(Expr, Domain, Criteria)
Case DCount_Wrapper
DomainFunctionWrapper = DCount(Expr, Domain, Criteria)
Case DSum_Wrapper
DomainFunctionWrapper = DSum(Expr, Domain, Criteria)
Case DMax_Wrapper
DomainFunctionWrapper = DMax(Expr, Domain, Criteria)
Case DMin_Wrapper
DomainFunctionWrapper = DMin(Expr, Domain, Criteria)
Case DSum_Wrapper
DomainFunctionWrapper = DSum(Expr, Domain, Criteria)
Case DAvg_Wrapper
DomainFunctionWrapper = DAvg(Expr, Domain, Criteria)
Case Else
' Unexpected DomainFunction argument
Debug.Assert False
End Select

Done:
Exit Function
ErrorHandler:
Debug.Print Err.Number & " - " & Err.Description

' Resume statement will be hit when debugging
If eh.LogError("DomainFunctionWrapper", _
"DomainFunction = " & DomainFunction, _
"Expr = " & Expr, _
"Domain = " & Domain, _
"Criteria = '" & Criteria & "'") Then Resume
End Function


'--------------------------------------------------------
' DLookupWrapper is just like DLookup only it will trap errors.
'--------------------------------------------------------
Public Function DLookupWrapper(Expr As String, Domain As String, Optional
Criteria As String) As Variant
DLookupWrapper = DomainFunctionWrapper(DLookup_Wrapper, Expr, Domain,
Criteria)
End Function


'--------------------------------------------------------
' DLookupStringWrapper is just like DLookup wrapped in an Nz
' This will always return a String.
'--------------------------------------------------------
Public Function DLookupStringWrapper(Expr As String, Domain As String,
Optional Criteria As String, Optional ValueIfNull As String = "") As
String
DLookupStringWrapper = Nz(DLookupWrapper(Expr, Domain, Criteria),
ValueIfNull)
End Function


'--------------------------------------------------------
' DLookupNumberWrapper is just like DLookup wrapped in
' an Nz that defaults to 0.
'--------------------------------------------------------
Public Function DLookupNumberWrapper(Expr As String, Domain As String,
Optional Criteria As String, Optional ValueIfNull = 0) As Variant
DLookupNumberWrapper = Nz(DLookupWrapper(Expr, Domain, Criteria),
ValueIfNull)
End Function


'--------------------------------------------------------
' DCountWrapper is just like DCount only it will trap errors.
'--------------------------------------------------------
Public Function DCountWrapper(Expr As String, Domain As String, Optional
Criteria As String) As Long
DCountWrapper = DomainFunctionWrapper(DCount_Wrapper, Expr, Domain,
Criteria)
End Function


'--------------------------------------------------------
' DMaxWrapper is just like DMax only it will trap errors.
'--------------------------------------------------------
Public Function DMaxWrapper(Expr As String, Domain As String, Optional
Criteria As String) As Long
DMaxWrapper = DomainFunctionWrapper(DMax_Wrapper, Expr, Domain,
Criteria)
End Function


'--------------------------------------------------------
' DMinWrapper is just like DMin only it will trap errors.
'--------------------------------------------------------
Public Function DMinWrapper(Expr As String, Domain As String, Optional
Criteria As String) As Long
DMinWrapper = DomainFunctionWrapper(DMin_Wrapper, Expr, Domain,
Criteria)
End Function


'--------------------------------------------------------
' DSumWrapper is just like DSum only it will trap errors.
'--------------------------------------------------------
Public Function DSumWrapper(Expr As String, Domain As String, Optional
Criteria As String) As Long
DSumWrapper = DomainFunctionWrapper(DSum_Wrapper, Expr, Domain,
Criteria)
End Function


'--------------------------------------------------------
' DAvgWrapper is just like DAvg only it will trap errors.
'--------------------------------------------------------
Public Function DAvgWrapper(Expr As String, Domain As String, Optional
Criteria As String) As Long
DAvgWrapper = DomainFunctionWrapper(DAvg_Wrapper, Expr, Domain,
Criteria)
End Function

*****
*****
RecordsetWrapper
*****
Option Compare Database
Option Explicit

Private m_rs As DAO.Recordset2


Public Function GetRecordsetClone(rs As DAO.Recordset2) As DAO.Recordset2
If Not m_rs Is Nothing Then
Debug.Assert False ' This is only designed to be used once
Else
Set m_rs = rs.Clone
Set GetRecordsetClone = m_rs
End If
End Function


Public Function OpenRecordset(Domain As String, _
Optional Criteria As String = "1=1", _
Optional OrderBy As String, _
Optional RecordsetType As
DAO.RecordsetTypeEnum = dbOpenDynaset, _
Optional RecordsetOptions As
DAO.RecordsetOptionEnum _
) As Boolean


If Not m_rs Is Nothing Then
' Close the recordset so it can be re-used
CloseRecordset
End If

Dim strSQL As String
strSQL = "SELECT * FROM [" & Domain & "] WHERE " & Criteria

If OrderBy <> "" Then
strSQL = strSQL & " ORDER BY " & OrderBy
End If

On Error GoTo ErrorHandler
Set m_rs = CurrentDb.OpenRecordset(strSQL, RecordsetType,
RecordsetOptions)
OpenRecordset = True

Done:
Exit Function
ErrorHandler:
' verify the private Recordset object was not set
Debug.Assert m_rs Is Nothing

' Resume statement will be hit when debugging
If eh.LogError("RecordsetWrapper.OpenRecordset", "strSQL = " & Chr
(34) & strSQL & Chr(34)) Then Resume
End Function


Public Function Delete() As Boolean
On Error GoTo ErrorHandler

m_rs.Delete
Delete = True

Done:
Exit Function
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("RecordsetWrapper.Delete") Then Resume
End Function


Public Function AddNew() As Boolean
On Error GoTo ErrorHandler

m_rs.AddNew
AddNew = True

Done:
Exit Function
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("RecordsetWrapper.AddNew") Then Resume
End Function


Public Function Edit() As Boolean
On Error GoTo ErrorHandler

m_rs.Edit
Edit = True

Done:
Exit Function
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("RecordsetWrapper.Edit") Then Resume
End Function


Public Function Update() As Boolean
On Error GoTo ErrorHandler

m_rs.Update
Update = True

Done:
Exit Function
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("RecordsetWrapper.Update") Then Resume
End Function


Public Function MoveNext() As Boolean
On Error GoTo ErrorHandler

m_rs.MoveNext
MoveNext = True

Done:
Exit Function
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("RecordsetWrapper.MoveNext") Then Resume
End Function


Public Function CloseRecordset() As Boolean
On Error GoTo ErrorHandler

m_rs.Close
CloseRecordset = True

Done:
Set m_rs = Nothing
Exit Function
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("RecordsetWrapper.CloseRecordset") Then Resume
End Function


Public Property Get Recordset() As DAO.Recordset2
Set Recordset = m_rs
End Property


Private Sub Class_Terminate()
If Not m_rs Is Nothing Then
m_rs.Close
Set m_rs = Nothing
End If
End Sub

*****
*****
Report_Monthly Sales Report
*****
Option Compare Database
Option Explicit


Private Sub Report_Open(Cancel As Integer)
On Error GoTo ErrorHandler
Dim strSQL As String

If IsNull(TempVars![Display]) Or IsNull(TempVars![Year]) Or IsNull
(TempVars![Month]) Or IsNull(TempVars![Group By]) Then
DoCmd.OpenForm "Sales Reports Dialog"
Cancel = True
Exit Sub
End If

strSQL = "SELECT [Year]"
strSQL = strSQL & ", [Month]"
strSQL = strSQL & ", First([" & TempVars![Display] & "]) AS
SalesGroupingField"
strSQL = strSQL & ", Sum([Sales]) AS [Total Sales]"
strSQL = strSQL & ", First([Sales Analysis].[Month Name]) AS [Month
Name]"
strSQL = strSQL & " FROM [Sales Analysis] "
strSQL = strSQL & " Where [Month]=" & TempVars![Month] & " AND [Year]
=" & TempVars![Year]
strSQL = strSQL & " GROUP BY [Year], [Month], [" & TempVars![Group
By] & "];"

Me.RecordSource = strSQL
Me.SalesGroupingField_Label.Caption = TempVars![Display]

Done:
Exit Sub
ErrorHandler:
' Resume statement will be hit when debugging
If eh.LogError("Monthly Sales Report_Open", "strSQL = " & strSQL)
Then
Resume
Else
Cancel = True
End If
End Sub
*****
*****
Form_Purchases Subform for Purchase Order Details
*****
Option Compare Database
Option Explicit


Sub InitParentState()
On Error Resume Next
Dim frmParent As [Form_Purchase Order Details]
Set frmParent = Me.Parent
frmParent.InitFormState
End Sub


Private Sub Form_AfterInsert()
InitParentState
End Sub


Private Sub Form_BeforeUpdate(Cancel As Integer)
If IsNull(Me![Unit Cost]) Then
MsgBoxOKOnly NeedUnitCost
Cancel = True
End If
End Sub


Private Sub Product_ID_AfterUpdate()
' We interpret this as user wanting to delete purchase item
' Suggested Enhancement: Prevent user from deleting items that have
been posted to inventory
If IsNull(Me![Product ID]) Then
RemoveCurrentLineItem
Else
Me![Unit Cost] = GetStandardCost(Me![Product ID])

' Suggested Enhancement: Combine same product iine items
End If
End Sub


Private Sub Quantity_AfterUpdate()
If Me![Quantity] = 0 Then
RemoveCurrentLineItem
End If
End Sub


Private Sub Quantity_BeforeUpdate(Cancel As Integer)
If Me![Posted To Inventory] Or Not IsNull(Me![Date Received]) Then
MsgBoxOKOnly CannotModifyPurchaseQuantity
Cancel = True
End If
End Sub


Private Sub Unit_Cost_BeforeUpdate(Cancel As Integer)
If Me![Posted To Inventory] Or Not IsNull(Me![Date Received]) Then
MsgBoxOKOnly CannotModifyPurchasePrice
Cancel = True
End If
End Sub

Private Function RemoveCurrentLineItem() As Boolean
RemoveCurrentLineItem = eh.TryToRunCommand(acCmdDeleteRecord)
End Function
*****
*****
PurchaseOrders
*****
Option Compare Database
Option Explicit

Public Enum PurchaseOrderStatusEnum
New_PurchaseOrder = 0
Submitted_PurchaseOrder = 1
Approved_PurchaseOrder = 2
Closed_PurchaseOrder = 3
End Enum


Function Generate(SupplierID As Long, ProductID As Long, Quantity As
Long, OrderID As Long, PurchaseOrderID As Long) As Boolean
Dim UnitCost As Long
UnitCost = GetStandardCost(Nz(ProductID, 0))
If Create(SupplierID, GetCurrentUserID(), OrderID, PurchaseOrderID)
Then
Generate = CreateLineItem(PurchaseOrderID, ProductID, UnitCost,
Quantity)
End If
End Function


Function Create(SupplierID As Long, EmployeeID As Long, OrderID As Long,
PurchaseOrderID As Long) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Purchase Orders") Then
With rsw.Recordset
.AddNew
![Supplier ID] = SupplierID
If EmployeeID > 0 Then
![Created By] = EmployeeID
![Creation Date] = Now()
![Submitted By] = EmployeeID
![Submitted Date] = Now()
![Status ID] = Submitted_PurchaseOrder
End If

If OrderID > 0 Then
![Notes] = InsertString(PurchaseGeneratedBasedOnOrder,
CStr(OrderID))
End If
If rsw.Update Then
.Bookmark = .LastModified
PurchaseOrderID = ![Purchase Order ID]
Create = True
End If
End With
End If
End Function


Function CreateLineItem(PurchaseOrderID As Long, ProductID As Long,
UnitCost As Long, Quantity As Long) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Purchase Order Details") Then
With rsw.Recordset
.AddNew
![Purchase Order ID] = PurchaseOrderID
![Product ID] = ProductID
![Quantity] = Quantity
![Unit Cost] = UnitCost
CreateLineItem = rsw.Update
End With
End If
End Function


Sub OpenOrder(Optional PurchaseOrderID As Long)
If (PurchaseOrderID > 0) Then
DoCmd.OpenForm "Purchase Order Details", acNormal, , "[Purchase
Order ID]=" & PurchaseOrderID, acFormEdit, acDialog
Else
DoCmd.OpenForm "Purchase Order Details", acNormal, , , acFormAdd,
acDialog
End If
End Sub


Sub NewOrder()
OpenOrder
End Sub


Function Delete(PurchaseOrderID As Long) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Purchase Orders", "[Purchase Order ID] = " &
PurchaseOrderID) Then
Delete = rsw.Delete
End If
End Function


Private Function SetStatus(PurchaseOrderID As Long, Status As
PurchaseOrderStatusEnum) As Boolean
Dim rsw As New RecordsetWrapper
If rsw.OpenRecordset("Purchase Orders", "[Purchase Order ID] = " &
PurchaseOrderID) Then
With rsw.Recordset
If Not .EOF Then
.Edit
![Status ID] = Status
Select Case Status
Case New_PurchaseOrder
![Creation Date] = Now()
![Created By] = GetCurrentUserID
Case Submitted_PurchaseOrder
![Submitted Date] = Now()
![Submitted By] = GetCurrentUserID
Case Approved_PurchaseOrder
![Approved Date] = Now()
![Approved By] = GetCurrentUserID
End Select
SetStatus = rsw.Update
End If
End With
End If
End Function


Function GetStatus(PurchaseOrderID) As PurchaseOrderStatusEnum
If IsNull(PurchaseOrderID) Then
GetStatus = New_PurchaseOrder
Else
GetStatus = DLookupNumberWrapper("[Status ID]", "Purchase
Orders", "[Purchase Order ID] = " & PurchaseOrderID, New_PurchaseOrder)
End If
End Function


Function MarkApproved(PurchaseOrderID As Long) As Boolean
If Not Privileges.CanApprovePurchases() Then
Exit Function
End If

If SetStatus(PurchaseOrderID, Approved_PurchaseOrder) Then
MarkApproved = True
End If
End Function


Function MarkSubmitted(PurchaseOrderID As Long) As Boolean
MarkSubmitted = SetStatus(PurchaseOrderID, Submitted_PurchaseOrder)
End Function


Function Exists(PurchaseOrderID As Long) As Boolean
Exists = Not IsNull(DLookupWrapper("[Purchase Order ID]", "Purchase
Orders", "[Purchase Order ID]=" & PurchaseOrderID))
End Function


Function GetStandardCost(lProductID As Long) As Currency
GetStandardCost = DLookupNumberWrapper("[Standard Cost]", "Products",
"[ID]=" & lProductID)
End Function


Function GetListPrice(lProductID As Long) As Currency
GetListPrice = DLookupNumberWrapper("[List Price]", "Products", "[ID]
= " & lProductID)
End Function
*****
*****
Module1
*****
Option Base 0
Option Compare Database
Option Explicit

Private Const cSeparator$ = "*****"

Private Sub SynopsisHack()
' a reference to the
' MicrosoftVBIDE Type Library
' must be set.
' the Sub
' VBIDEReference
' (below)
' may effect this.
Dim pCode$
Dim pCodeModule As CodeModule
Dim pErrorNumber&
Dim pFileName$
Dim pFileNumber%
Dim pIterator0&
Dim pIterator1&
Dim pVBComponent As VBComponent
Dim pVBProject As VBProject
With VBE.VBProjects
For pIterator0 = 1 To .Count
Set pVBProject = .Item(pIterator0)
pCode = pCode & vbNewLine & cSeparator & cSeparator
pCode = pCode & vbNewLine & pVBProject.Name
pCode = pCode & vbNewLine & cSeparator & cSeparator
With pVBProject.VBComponents
For pIterator1 = 1 To .Count
Set pVBComponent = .Item(pIterator1)
Set pCodeModule = pVBComponent.CodeModule
pCode = pCode & vbNewLine & cSeparator
pCode = pCode & vbNewLine & pVBComponent.Name
pCode = pCode & vbNewLine & cSeparator
pCode = pCode & vbNewLine & pCodeModule.Lines(1,
pCodeModule.CountOfLines)
pCode = pCode & vbNewLine & cSeparator
Next pIterator1
End With
Next pIterator0
End With
pFileNumber = FreeFile
pFileName = Replace(CurrentProject.Name, ".mdb", "") & "Code.txt"
On Error Resume Next
Kill pFileName
On Error GoTo 0
Open pFileName For Binary As #pFileNumber
Put #pFileNumber, , pCode
Close #pFileNumber
Shell "NotePad " & pFileName, vbNormalFocus
End Sub

Private Sub VBIDEReference()
Const cMicrosoftVBIDETypeLibraryLocation$ = _
"C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6
\VBE6EXT.OLB"
Const cMicrosoftVBIDEGuid$ = _
"{0002E157-0000-0000-C000-000000000046}"
On Error Resume Next
With References
.AddFromGuid cMicrosoftVBIDEGuid, 5, 3
.AddFromFile cMicrosoftVBIDETypeLibraryLocation
End With
End Sub

*****



--
lyle fairfield

- The man who told us that Canada wouldn't go there has now told us that
Canada will be the first to come back. How reassuring!

Benny Andersen wrote:


Well, I never used A2K, but the Modules collection has
always contained "all open standard modules and class
modules" (VBA Help). Note that it does not say anything
about containing closed modules, form modules or report
modules.

You can get a list of all standard and class modules via
either the Forms/Reports/Modules Container and related
Documents collection or the All{Forms|Reports|Modules}
collections.

The OpenModule method can only be used to open standard and
class modules. To get to a form/report module, you must
(Lyle's innovative code aside) open the form/report and then
reference it's Module property.

To sum up, your expection/understanding is off base. Spend
some more time gaining more knowledge of the
objects/collections you are trying to work with. VBA Help
is usually(?) a good source of information (if you can find
the pertinent topic).

--
Marsh

Thank you very much - the code was god inspiration. It dosn't attach
the problem i had, but gives some other objects to solve the problem:
vbe.VBProjects("<projectsname>").VBComponents
("<modulename>").CodeModule.Find(...)

I too found the use of class references usefull, something i have
briefly had thought many times, but newer found the solution for
before now. Found out, that just one parameter was enough:

References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 3

it is potentially confligting with both GUID and pathname, and, when
pathName can be obmitted, it reduces coupling to systemdrive and the
way 'common files' is named in non english windows installations.

From now on, all my access databases must have a:
Sub setReference()
On Error Resume Next
References.AddFromGuid "{00020430-0000-0000-C000-000000000046}",
2, 0
References.AddFromGuid "{00025E01-0000-0000-C000-000000000046}",
5, 0
References.AddFromGuid "{00000201-0000-0010-8000-00AA006D2EA4}",
2, 1
References.AddFromGuid "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}",
2, 0
References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}",
5, 3
.....
End Sub

... mostly for documentaion purphoses, as the references choice is
bound the the *.mdb file.

fetched from immediate window by use of :

Function referencesArr()
Dim r As Reference
For Each r In References
With r
If Not .BuiltIn Then
If .Kind Then
add2list referencesArr, "references.AddFromFile
""" & .FullPath & """"
Else
add2list referencesArr, "References.AddFromGuid
""" & .Guid & """," & .Major _
& "," & .Minor: End If: End If
End With: Next
End Function
?arr2list(referencesArr(),vbcrlf)

I havn't read the code lines concerning the northwin database - do i
miss something there?

--
Benny Andersen

On 19 Apr., 18:55, Marshall Barton <marshbar... (AT) wowway (DOT) com> wrote:


corrupt with respect to 'help' -
Well, stuck with the internet, it is seldom i have to ask myself - the
google archives has the answer 499/500 times.

Thanks for your reply
--
Benny Andersen