Option Compare Database
Option Explicit
'---- 24 July 2002
'---- Adding in all simple look up tables to the shared mdb - and so I'm changing all - yes all - the links via all the
'---- screens so that they look here
'----
'---- 3 July 2002
'---- Corrupted (shock horror!) and I mean really corrupted - not just one form but forms and coding
'----
'---- 18 Feb 2002
'---- Beware corrupting dbs...
'----
'---- Feb 2002
'---- Redoing Access 97
'---- heheh
'---- 25 May 2001
'---- For my next trick I shall reconvert it all back to dao 97...
'----
'---- 08/03/2001 - 17/03/2001 (St Pats day!)
'---- converted to Access 2k - including changing the references to ado...
'---- fun...
'---- btw - this is likely to eat memory - but generally 'feels' better.
'---- BUT does allow changing of the tables whilst users have them open... Sorta
'---- this opens the table and grabs the information required then closes the table
'---- The listbox combo to tables (faster) holds the tables open, which could stop development... My excuse not to use
'---- Developer choice anyway
'---- 20/05/99 ----'
'---- List box fillers... Do we have fun or what ?
'---- how to use
'---- 1) set up a variable which points to this class module (must be global or form global so it's held open)
'---- 2) set up the usual list box caller function (just the function name and args)
'---- 3) set the control, varid, rows, cols and code to whichever
'---- 4) set the code to run (mintF) (from 0 to how ever many code initializes)
'---- 5) call 'returninfo' as a variant (returned)
'---- 6) set and return this in your function call (like usual)
Private ctl As Control '-The stuff from 'normal' list boxes
Private varID As Variant
Private mlngRow As Long
Private mlngCol As Long
Private mintCode As Integer
Private aColWidth() As Integer '-array of widths
Private aData() As String '-array of data
Private mintF As Integer '-which code to fill ?
Private mlngItems As Long '-no of items
Private mintC As Integer '-columns
Private mstrInfo As String '- Extra info (search criteria? sql?)
Private mblnUseHeader 'first line is header of listbox...
Public Property Get aInfo() As String
aInfo = mstrInfo
End Property
Public Property Let aInfo(ByVal strNew As String)
mstrInfo = strNew
End Property
Public Property Get aControl() As Control
Set aControl = ctl
End Property
Public Property Let aControl(ByVal ctlNew As Control)
Set ctl = ctlNew
End Property
Public Property Get aIDVar() As Variant
aIDVar = varID
End Property
Public Property Let aIDVar(ByVal varNew As Variant)
varID = varNew
End Property
Public Property Get aRow() As Long
aRow = mlngRow
End Property
Public Property Let aRow(ByVal lngNew As Long)
mlngRow = lngNew
End Property
Public Property Get aCol() As Long
aCol = mlngCol
End Property
Public Property Let aCol(ByVal lngNew As Long)
mlngCol = lngNew
End Property
Public Property Get aCode() As Integer
aCode = mintCode
End Property
Public Property Let aCode(ByVal intNew As Integer)
mintCode = intNew
End Property
Public Property Get aFillWith() As Integer
aFillWith = mintF
End Property
Public Property Let aFillWith(ByVal intNew As Integer)
mintF = intNew
End Property
Public Property Let aHasHeader(ByVal blnNew As Boolean)
mblnUseHeader = blnNew
End Property
Public Property Get aHasHeader() As Boolean
aHasHeader = mblnUseHeader
End Property
Private Sub Class_Initialize()
ReDim aData(0, 0)
mlngItems = 0
mstrInfo = ""
End Sub
Private Sub Class_Terminate()
'---- clean out the array as you leave, please...
Erase aData
End Sub
Public Function fReturnInfo() As Variant
Dim varRet As Variant
Dim lngErr As Long, strErr As String
lngErr = Err.Number
strErr = Err.Description
On Error Resume Next
Select Case mintCode
Case acLBInitialize
ReDim aData(0, 0)
mlngItems = 0
mintC = 1
Select Case mintF
Case 0
'---- insert the list creater sub
'---- included in the sub should be : (hint see those here already ? ;)
'---- must make a list of values to be viewed (usual)
'---- must set mintC (no of columns)
'---- must set aColWidth() 's for each column
Case 1
CustSearchList
Case 2
SalesEnquiriesFilteredList
Case 10
UsefulFoldersList
Case 20
SEActionsList
Case 25
PlatformsList
Case 26
VehicleLUList
Case 100
zLUSimple "Titles"
Case 101
zLUSimple "SEAct"
'---- Lookups - Shared
End Select
varRet = True
Case acLBOpen
varRet = Timer
Case acLBGetColumnCount
varRet = mintC
Case acLBGetRowCount
varRet = mlngItems
Case acLBGetColumnWidth
If mlngCol > 0 Then
varRet = aColWidth(mlngCol)
Else
varRet = 0
End If
Case acLBGetValue
varRet = aData(mlngRow, mlngCol)
Case acLBGetFormat
varRet = Null
End Select
fReturnInfo = varRet
If Not lngErr = 0 Then Err.Raise lngErr, , strErr
End Function
'---- this is the function which MUST be put on the forms code
'---- you need to copy it there, change the function name, type the new name into the list/combo data field instead of table/query
'---- delete the 'Dim lbinf As New clsLists' and change '.afillwith' to the correct number
Function Fill(ctl As Control, varID As Variant, mlngRow As Long, mlngCol As Long, mintCode) As Variant
Dim varRetval As Variant
Dim lbinf As New clsListShared
Dim lngErr As Long, strErr As String
If Not Err.Number = 0 Then
lngErr = Err.Number
strErr = Err.Description
End If
On Error Resume Next
Err.Clear
With lbinf
.aControl = ctl
.aIDVar = varID
.aCol = mlngCol
.aRow = mlngRow
.aCode = mintCode
.aHasHeader = True
.aFillWith = 0
.aInfo = ""
varRetval = .fReturnInfo
End With
Fill = varRetval
If Not lngErr = 0 Then Err.Raise lngErr, , strErr
End Function
Reply With Quote
