快速開發平臺--自定義類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