📄 strings.cls
字号:
' GetNextFormatCode = "0" & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = IIf(lastC >= "0" And lastC <= "9", lastC, "0") & GetNextFormatCode
' End If
' End If
' End If
' Case "@" '大写字母字符
' If Conversion Then
' GetNextFormatCode = c & GetNextFormatCode
' Conversion = False
' Else
' If Desc Then '字母字符递减 Z-A
' If TryNext Then
' If lastC <> "A" Then
' TryNext = False
' If lastC < "A" Or lastC > "Z" Then
' GetNextFormatCode = "Z" & GetNextFormatCode
' Else
' GetNextFormatCode = Trim(Chr(Asc(lastC) - 1)) & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = "Z" & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = IIf(lastC >= "A" And lastC <= "Z", lastC, "Z") & GetNextFormatCode
' End If
'
' Else '字母字符递增 A-Z
' If TryNext Then
' If lastC <> "Z" Then
' TryNext = False
' If lastC < "A" Or lastC > "Z" Then
' GetNextFormatCode = "A" & GetNextFormatCode
' Else
' GetNextFormatCode = Trim(Chr(Asc(lastC) + 1)) & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = "A" & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = IIf(lastC >= "A" And lastC <= "Z", lastC, "A") & GetNextFormatCode
' End If
' End If
' End If
' Case "*" '小写字母字符
' If Conversion Then
' GetNextFormatCode = c & GetNextFormatCode
' Conversion = False
' Else
' If Desc Then '字母字符递减 z-a
' If TryNext Then
' If lastC <> "a" Then
' TryNext = False
' If lastC < "a" Or lastC > "z" Then
' GetNextFormatCode = "z" & GetNextFormatCode
' Else
' GetNextFormatCode = Trim(Chr(Asc(lastC) - 1)) & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = "z" & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = IIf(lastC >= "a" And lastC <= "z", lastC, "z") & GetNextFormatCode
' End If
'
' Else '字母字符递增 a-z
' If TryNext Then
' If lastC <> "z" Then
' TryNext = False
' If lastC < "a" Or lastC > "z" Then
' GetNextFormatCode = "a" & GetNextFormatCode
' Else
' GetNextFormatCode = Trim(Chr(Asc(lastC) + 1)) & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = "a" & GetNextFormatCode
' End If
' Else
' GetNextFormatCode = IIf(lastC >= "a" And lastC <= "z", lastC, "a") & GetNextFormatCode
' End If
' End If
' End If
' Case "d" '取当前日值
' If Conversion Then
' GetNextFormatCode = c & GetNextFormatCode
' Conversion = False
' Else
' GetNextFormatCode = Mid(DateStr, 8 - nD, 1) + GetNextFormatCode
' nD = IIf(nD = 1, 0, nD + 1)
' End If
' Case "m" '取当前月值
' If Conversion Then
' GetNextFormatCode = c & GetNextFormatCode
' Conversion = False
' Else
' GetNextFormatCode = Mid(DateStr, 6 - nM, 1) + GetNextFormatCode
' nM = IIf(nM = 1, 0, nM + 1)
' End If
' Case "y" '取当前年值
' If Conversion Then
' GetNextFormatCode = c & GetNextFormatCode
' Conversion = False
' Else
' GetNextFormatCode = Mid(DateStr, 4 - nY, 1) + GetNextFormatCode
' nY = IIf(nY = 3, 0, nY + 1)
' End If
' Case "%" '转意符
' If Conversion Then
' GetNextFormatCode = c & GetNextFormatCode
' Conversion = False
' Else
' Conversion = True
' End If
' Case Else '其它固定字符
' GetNextFormatCode = c & GetNextFormatCode
' End Select
' If i = 1 Then
' If TryNext Then '编码已到极限，无法再递增或递减，函数返回空串。
' GetNextFormatCode = ""
' End If
' Exit Function
' End If
' i = i - 1
' Loop
'End Function
Public Function CodeIsFormated(CodeStr As String, FormatStr As String) As Boolean
CodeIsFormated = (CodeStr = GetNextFormatCode(GetNextFormatCode(CodeStr, FormatStr), FormatStr, True))
End Function
'***************************************************************************************
'*****************************************************************************************
Public Function GetICKey(ActiveConnection As Connection, TableName As String, FieldName As String, _
Optional ByVal FieldType As ICKeyDataType = StringType, Optional ByVal ICKey As String = "自动", _
Optional ByVal FFormat As String, Optional ByVal hStr As String, Optional ByVal CheckFormat As Boolean, _
Optional ByVal IsRegister As Boolean = True, Optional ByVal AddOrEdit As ICKeyAddOrEdit = recAdd, _
Optional ByVal OldICKey As String, Optional AttachFilter As String, Optional ByVal StartKey As String, _
Optional ByVal ExistPromptMsg As String = "此代码已使用！") As String
If ActiveConnection.State = 0 Or Trim(TableName) = "" Or Trim(FieldName) = "" Then
MsgBox "无效的参数！", vbExclamation, "系统提示"
GetICKey = ""
Exit Function
End If
On Error GoTo er
Dim strSQL As String
Dim rs As New Recordset
Dim Indirect As String
Dim mICKey As String
Indirect = IIf(FieldType = StringType, "'", "")
ICKey = Trim(ICKey)
TranMark OldICKey
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If ICKey = "自动" Or ICKey = "自动生成" Then
strSQL = "Select FMaxKey,FFormat from ICMaxKey where FTableName='" & TableName & "' And FFieldName='" & FieldName & "'"
rs.Open strSQL, ActiveConnection, adOpenStatic, adLockReadOnly
If Not rs.EOF Then
If FieldType = StringType Then
If FFormat = "" Then
FFormat = IIf(Trim(rs!FFormat) <> "", Trim(rs!FFormat), "###")
End If
If CodeIsFormated(Trim(rs!FMaxKey), FFormat) Then
ICKey = GetNextFormatCode(Trim(rs!FMaxKey), FFormat)
Else
ICKey = GetNextFormatCode(StartKey, FFormat)
End If
Else
ICKey = Val(rs!FMaxKey) + 1
End If
Else
If FieldType = StringType Then
FFormat = IIf(Trim(FFormat) <> "", Trim(FFormat), "###")
ICKey = GetNextFormatCode(StartKey, FFormat)
Else
ICKey = 1
End If
End If
rs.Close
If ICKey = "" Then
MsgBox "编码已满，请拓展编码格式！", 48, "系统提示"
GetICKey = ""
Exit Function
End If
Do While True '''''''''''*
strSQL = "Select Count(" & FieldName & ") As Exist from " & TableName & _
" Where " & FieldName & "=" & Indirect & hStr & ICKey & Indirect & _
IIf(AddOrEdit = recEdit, IIf(Trim(OldICKey) <> "", _
" And " & FieldName & "<>" & Indirect & OldICKey & Indirect, ""), "") & _
IIf(Trim(AttachFilter) <> "", " And ", "") & AttachFilter
rs.Open strSQL, ActiveConnection, adOpenStatic, adLockReadOnly
If rs!Exist = 0 Then
rs.Close
Exit Do
End If
rs.Close
If FieldType = StringType Then
ICKey = GetNextFormatCode(Trim(ICKey), FFormat)
If ICKey = "" Then
MsgBox "编码已满，请拓展编码格式！", 48, "系统提示"
GetICKey = ""
Exit Function
End If
Else
ICKey = ICKey + 1
End If
Loop ''''''''''''*
If IsRegister Then
ActiveConnection.Execute "Update ICMaxKey Set FMaxKey='" & ICKey & "' where FTableName='" & TableName & "' And FFieldName='" & FieldName & "'"
End If
GetICKey = hStr & ICKey
Else
If CheckFormat Then '需检查用户编码格式
If FFormat = "" Then '取编码格式
strSQL = "Select FFormat from ICMaxKey where FTableName='" & TableName & "' And FFieldName='" & FieldName & "'"
rs.Open strSQL, ActiveConnection, adOpenStatic, adLockReadOnly
FFormat = IIf(Trim(rs!FFormat) <> "", Trim(rs!FFormat), "###")
rs.Close
End If
If hStr = "" Then
If Not CodeIsFormated(ICKey, FFormat) Then
MsgBox "编码不符合格式[" & FFormat & "]！", 48, "系统提示"
GetICKey = ""
Exit Function
End If
Else
If Left(ICKey, Len(hStr)) <> hStr Or Not CodeIsFormated(Mid(ICKey, Len(hStr) + 1), FFormat) Then
MsgBox "编码不符合格式[" & FFormat & "]！", 48, "系统提示"
GetICKey = ""
Exit Function
End If
End If
End If
mICKey = ICKey
strSQL = "Select Count(" & FieldName & ") As Exist from " & TableName & _
" Where " & FieldName & "=" & Indirect & TranMark(mICKey) & Indirect & _
IIf(AddOrEdit = recEdit, IIf(Trim(OldICKey) <> "", _
" And " & FieldName & "<>" & Indirect & TranMark(OldICKey) & Indirect, ""), "") & _
IIf(Trim(AttachFilter) <> "", " And ", "") & AttachFilter
rs.Open strSQL, ActiveConnection, adOpenStatic, adLockReadOnly
If rs!Exist > 0 Then
rs.Close
If ExistPromptMsg <> "" Then
MsgBox ExistPromptMsg, 0 + 48, "操作提示"
End If
GetICKey = ""
Exit Function
End If
rs.Close
Set rs = Nothing
GetICKey = ICKey
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Exit Function
er:
MsgBox "数据库访问错误(或找不到[ICMaxKey]表),请检查数据库！[" & err.Description & "]", vbExclamation, "系统提示"
GetICKey = ""
End Function
Public Function RegisterICKey(ActiveConnection As Connection, TableName As String, FieldName As String, _
ByVal ICKey As String) As Boolean
Dim strSQL As String
strSQL = "Update ICMaxKey Set FMaxKey='" & ICKey & "' Where FTableName='" & TableName & "' And FFieldName='" & _
FieldName & "'"
On Error GoTo err
ActiveConnection.Execute strSQL
RegisterICKey = True
Exit Function
err:
End Function
Public Function RegisterBillNo(ActiveConnection As Connection, ProjID As String, _
ByVal ICKey As String) As Boolean
Dim strSQL As String
strSQL = "Update ICMaxBillNo Set FMaxKey='" & ICKey & "' Where FProjID='" & ProjID & "'"
On Error GoTo err
ActiveConnection.Execute strSQL
RegisterBillNo = True
Exit Function
err:
End Function
'**************************************************************************************************
Public Function GetBillNo(ActiveConnection As Connection, ProjectID As String, Optional ByVal ICKey As String = "自动", _
Optional ByVal FFormat As String, Optional ByVal CheckFormat As Boolean, _
Optional ByVal IsRegister As Boolean = True, Optional ByVal AddOrEdit As ICKeyAddOrEdit = recAdd, _
Optional ByVal OldICKey As String, Optional AttachFilter As String, _
Optional ByVal ExistPromptMsg As String = "此单号已使用！") As String
On Error GoTo er
Dim strSQL As String
Dim rs As New Recordset
Dim Indirect As String
Dim TableName As String
Dim FieldName As String
Dim FBillType As Integer
Dim mICKey As String
ICKey = Trim(ICKey)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
strSQL = "Select FtableName,FFieldName, FBillType,FMaxKey,FFormat from ICMaxBillNo where FProjID='" & ProjectID & "'"
rs.Open strSQL, ActiveConnection, adOpenStatic, adLockReadOnly
If Not rs.EOF Then
TableName = rs!FTableName
FieldName = rs!FFieldName
FBillType = rs!FBillType
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -