快速开发平台--自定义类CodeGenerator

时　间: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