快速开发平台--自定义类CodeGenerator
来源:www.accessoft.com 点击数:1003 评论数:0 评论 | 收藏 | 复制
时 间:2013-12-18 18:51:45
作 者:Aaron ID：20267 城市：闵行
摘 要:自定义类CodeGenerator，可以代替平台的GetAutoNumber函数，更灵活
正 文:
自定义类CodeGenerator，可以代替平台的GetAutoNumber函数
类的调用：
Private Sub btnAutoCode_Click()
Dim clsAutoCode As CodeGenerator
Set clsAutoCode = New CodeGenerator
With clsAutoCode
' .RuleName = "InventoryCode"
.Domain = "tblInventory"
.Field = "InventoryCode"
.Prefixal = "CM0501"
.Digit = 3
.ReplenishOffNo = True
MsgBox .CodeGenerator
End With
Set clsAutoCode = Nothing
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
类代码：
Option Compare Database
Option Explicit
'//字段变量
Private mstrRuleName As String
Private mstrDomain As String
Private mstrField As String
Private mstrPrefixal As String
Private mstrDateFormat As String
Private mstrNumberDate As String
Private mlngDigit As Long
Private mblnReplenishOffNo As Boolean
'//模块变量
Private mblnHasRule As Boolean
Private mblnCorrectData As Boolean
Private mstrWrongMessage As String
Public Event InvalidData(strMessage As String)
'//RuleName属性,只可写
Public Property Let RuleName(ByVal astrRuleName As String)
Dim rstRules As ADODB.Recordset
Dim strRules As String
mstrRuleName = astrRuleName
strRules = "Select * FROM Sys_AutoNumberRules Where RuleName='" & mstrRuleName & "'"
Set rstRules = OpenADORecordset(strRules, adLockOptimistic, CurrentProject.Connection)
With rstRules
If .EOF Then
MsgBox "自动编号规则 <" & mstrRuleName & ">不存在!", vbCritical, "自动编号类"
mblnHasRule = False
GoTo ExitHere
End If
'//将规则参数读入到类变量中
'//采用属性的方式来读入，是防止表中的数据不合法
Me.Domain = Nz(!Domain, "")
Me.Field = Nz(!Field, "")
Me.Prefixal = Nz(!Prefixal, "")
Me.DateFormat = Nz(!DateFormat, "")
Me.Digit = Nz(!Digit, 0)
Me.ReplenishOffNo = !ReplenishOffNo
mblnHasRule = True
End With
ExitHere:
rstRules.Close
Set rstRules = Nothing
Exit Property
End Property
'//Domain属性
Public Property Get Domain() As String
Domain = mstrDomain
End Property
Public Property Let Domain(ByVal astrDomain As String)
mstrDomain = astrDomain
End Property
'//Field属性
Public Property Get Field() As String
Field = mstrField
End Property
Public Property Let Field(ByVal astrField As String)
mstrField = astrField
End Property
'//Prefixal属性
Public Property Get Prefixal() As String
Prefixal = mstrPrefixal
End Property
Public Property Let Prefixal(ByVal astrPrefixal As String)
mstrPrefixal = astrPrefixal
End Property
'//DateFormat属性
Public Property Get DateFormat() As String
DateFormat = mstrDateFormat
End Property
Public Property Let DateFormat(ByVal astrDateFormat As String)
mstrDateFormat = astrDateFormat
End Property
'//NumberDate属性
Public Property Get NumberDate() As String
NumberDate = mstrNumberDate
End Property
Public Property Let NumberDate(ByVal astrNumberDate As String)
mstrNumberDate = astrNumberDate
End Property
'//Digit属性
Public Property Get Digit() As Long
Digit = mlngDigit
End Property
Public Property Let Digit(ByVal alngDigit As Long)
If Abs(CLng(alngDigit)) = alngDigit Then
mlngDigit = alngDigit
Else
MsgBox "自增字段位数参数错误！使用默认值3！", vbCritical, "参数错误"
mlngDigit = 3
End If
End Property
'//ReplenishOffNo属性
Public Property Get ReplenishOffNo() As Boolean
ReplenishOffNo = mblnReplenishOffNo
End Property
Public Property Let ReplenishOffNo(ByVal ablnReplenishOffNo As Boolean)
mblnReplenishOffNo = ablnReplenishOffNo
End Property
Public Function CodeGenerator() As String
Dim rstCodeSource As DAO.Recordset
Dim strCodeSource As String
If mblnHasRule = False Then
strCodeSource = "Select " & mstrField & " FROM " & mstrDomain _
& " Where " & mstrField & " LIKE '" & mstrPrefixal & "*' " _
& "ORDER BY " & mstrField
On Error GoTo SourceError
Set rstCodeSource = CurrentDb.OpenRecordset(strCodeSource)
On Error GoTo ErrorHandler
With rstCodeSource
If .EOF Then
CodeGenerator = mstrPrefixal & FormatNumber(1, mlngDigit)
Else
If mblnReplenishOffNo Then
CodeGenerator = mstrPrefixal & FormatNumber(ReplenishTable(rstCodeSource), mlngDigit)
Else
.MoveLast '//不查找断码的话，直接移动到最后一条记录
CodeGenerator = Replace(.Fields(mstrField), mstrPrefixal, "")
If IsNumeric(CodeGenerator) Then
CodeGenerator = CodeGenerator + 1
CodeGenerator = mstrPrefixal & FormatNumber(CLng(CodeGenerator), mlngDigit)
Else
MsgBox "请检查输入的前缀参数！", vbCritical, "参数"
CodeGenerator = ""
GoTo ExitHere
End If
End If
End If
End With
Else
CodeGenerator = GetAutoNumber(mstrRuleName)
End If
ExitHere:
If Not (rstCodeSource Is Nothing) Then
rstCodeSource.Close
Set rstCodeSource = Nothing
End If
Exit Function
SourceError:
MsgBox "请检查输入的表与字段参数！"
Exit Function
ErrorHandler:
MsgBox Err.Description
Resume ExitHere
End Function
Private Function FormatNumber(lngNumber As Long, lngDigit As Long) As String
Dim intRepeat As Integer
If lngNumber >( 10 ^ lngDigit-1) Then
MsgBox "自增序号溢出，请检查自增数字段的位数!", vbCritical, "溢出"
FormatNumber = ""
Exit Function
End If
intRepeat = lngDigit - Len(CStr(lngNumber))
FormatNumber = Space(intRepeat) & lngNumber
FormatNumber = Replace(FormatNumber, Space(1), "0")
End Function
'//-----------------二分法查找断码---------------------------------
Private Function ReplenishTable(rstArea As DAO.Recordset) As Long
Dim lngStart As Long
Dim lngMax As Long
On Error GoTo ErrorHandler
With rstArea
If .RecordCount = 0 Then
ReplenishTable = 1
GoTo ExitHere
End If
.MoveLast
lngMax = Replace(.Fields(0), mstrPrefixal, "")
If Not IsNumeric(lngMax) Then
MsgBox "请检查前缀和表的字段！", vbCritical, "提示"
GoTo ExitHere
End If
' ReplenishTable = LossNumber(TableName, FieldName, 1, lngMax)
ReplenishTable = LossNumber(rstArea, 1, lngMax)
End With
ExitHere:
If Not (rstArea Is Nothing) Then
rstArea.Close
Set rstArea = Nothing
End If
Exit Function
ErrorHandler:
ReplenishTable = -1
MsgBox Err.Number & Err.Description
Resume ExitHere
End Function
Private Function LossNumber(rstArea As DAO.Recordset, _
Optional StartNumber As Long = -1, _
Optional EndNumber As Long = -1, _
Optional LastEnd As Long = -1 _
) As Long
Dim lngCountRecords As Long
Dim lngCalRecords As Long
Dim lngNextStart As Long, lngNextEnd As Long, lngNextLast As Long
If StartNumber = -1 Then StartNumber = 1
lngCountRecords = CountRecords(rstArea, StartNumber, EndNumber)
lngCalRecords = CalRecords(StartNumber, EndNumber)
If lngCountRecords > 0 Then
If lngCountRecords = lngCalRecords Then
If LastEnd = -1 Then
' MsgBox "没有断码！"
LossNumber = lngCalRecords + 1
Exit Function
Else
'//后半区间
lngNextStart = EndNumber + 1
lngNextEnd = LastEnd
lngNextLast = LastEnd
End If
Else
'//前半区间
lngNextStart = StartNumber
lngNextEnd = CLng((EndNumber - StartNumber) / 2) + StartNumber
lngNextLast = EndNumber
End If
LossNumber = LossNumber(rstArea, lngNextStart, lngNextEnd, lngNextLast)
Else
LossNumber = StartNumber
End If
End Function
'//返回区间内的实际记录数
Private Function CountRecords(rstArea As DAO.Recordset, StartNumber As Long, EndNumber As Long) As Long
Dim strFilter As String
Dim strStartField As String
Dim strEndField As String
Dim rstFiltered As DAO.Recordset
strStartField = mstrPrefixal & FormatNumber(StartNumber, mlngDigit)
strEndField = mstrPrefixal & FormatNumber(EndNumber, mlngDigit)
strFilter = "(" & mstrField & " >= '" & strStartField & "' ) AND (" & mstrField & "<='" & strEndField & "')"
With rstArea
.Filter = strFilter
Set rstFiltered = .OpenRecordset
End With
With rstFiltered
If .EOF Then
CountRecords = 0
Exit Function
End If
.MoveLast
.MoveFirst
CountRecords = .RecordCount
.Close
Set rstFiltered = Nothing
End With
End Function
'//返回区间内如果无断码情况时的记录数
Private Function CalRecords(StartNumber As Long, EndNumber As Long) As Long
CalRecords = EndNumber - StartNumber + 1
End Function