|
Option Compare Database
Option Explicit
'-------------------------
'编者 张义成（儿化韵）
'日期 2016-07-30
'-------------------------
'控件属性：
'txt金额数字：格式 空白。 小数位数 自动。 文本对齐 右。 是否锁定 否。 制表位 是。
'txt金额大写：格式 空白。 小数位数 自动。 文本对齐 左。 是否锁定 是。 制表位 否。
'txt金额单位：格式 空白。 小数位数 自动。 文本对齐 左。 是否锁定 是。 制表位 否。背景样式 透明。
'默认值 "人民币 亿 仟 佰 拾 万 仟 佰 拾 元 角 分"
'与 txt金额大写 叠合。
'-------------------------
Private Sub txt金额数字_AfterUpdate()
On Error GoTo ErrorHandler
Call fun金额大写
Me.txt空白.SetFocus
ErrorHandlerExit:
Me.txt空白.SetFocus
Exit Sub
ErrorHandler:
MsgBox "Error No：" & Err.Number & " Description：" & Err.Description
Resume ErrorHandlerExit
End Sub
Private Function fun金额大写()
Dim varA As Variant
Dim varB As Variant
Dim strE As String
Dim strF As String
Dim varH As Variant
Dim varJ As Variant
Dim varK As Variant
Dim varM As Variant
Dim varN As Variant
Dim strQ As String
Dim strR As String
Dim strS As String
Dim strT As String
Dim lngV As Long
Dim lngW As Long
Dim lngX As Long
Dim lngY As Long
varM = txt金额数字
If IsNumeric(varM) Then
'应用 varM = Val(varM) 赋值语句，可以直接舍弃数字首尾的 0 和尾部的点号（.），
'但是 Val() 函数遇到超长整数时，会以 CDbl() 函数替代转换，所以不宜在此使用。
'本示例整数部分按长整型处理，从 -2,147,483,648 到 2,147,483,647 。超出范围，系统将会报告溢出。
'由于负值没有实际意义，故将 - 号去掉，变为正值。由此，-2,147,483,648 也会溢出。
'本示例最高位值为亿，故超出部分会被舍弃。
txt金额数字备份 = varM
varM = Replace(varM, "-", "")
If Right(varM, 1) = "." Then varM = Left(varM, Len(varM) - 1)
varN = InStr(varM, ".")
Select Case varN
Case 0
varA = CLng(varM)
If Len(varA) > 9 Then varA = Right(varA, 9)
lngV = Len(varA)
lngW = 1
Do
varJ = Mid(varA, lngW, 1)
Select Case varJ
Case 0
strQ = "零 "
Case 1
strQ = "壹 "
Case 2
strQ = "贰 "
Case 3
strQ = "叁 "
Case 4
strQ = "肆 "
Case 5
strQ = "伍 "
Case 6
strQ = "陆 "
Case 7
strQ = "柒 "
Case 8
strQ = "捌 "
Case 9
strQ = "玖 "
Case Else
MsgBox "代码 fun金额大写() 的 Case 0 组 Select Case varJ 段 Case Else 报告出错 ！", vbExclamation, "郑重提示"
Exit Function
End Select
strR = strR & strQ
lngW = lngW + 1
Loop Until lngW = lngV + 1
Select Case lngV
Case 1
strE = "× × × × × × × × " & strR
Case 2
strE = "× × × × × × × " & strR
Case 3
strE = "× × × × × × " & strR
Case 4
strE = "× × × × × " & strR
Case 5
strE = "× × × × " & strR
Case 6
strE = "× × × " & strR
Case 7
strE = "× × " & strR
Case 8
strE = "× " & strR
Case 9
strE = strR
Case Else
MsgBox "代码 fun金额大写() 的 Case 0 组 Select Case lngV 段 Case Else 报告出错 ！", vbExclamation, "郑重提示"
Exit Function
End Select
txt金额数字 = varA
varH = Format(varA, "#,##0")
txt金额大写 = "人民币" & strE & "× × " & " ￥" & varH
Case 1
varB = Mid(varM, InStr(varM, ".") + 1)
If Len(varB) > 2 Then varB = Left(varB, 2)
lngX = Len(varB)
lngY = 1
Do
varK = Mid(varB, lngY, 1)
Select Case varK
Case 0
strS = "零 "
Case 1
strS = "壹 "
Case 2
strS = "贰 "
Case 3
strS = "叁 "
Case 4
strS = "肆 "
Case 5
strS = "伍 "
Case 6
strS = "陆 "
Case 7
strS = "柒 "
Case 8
strS = "捌 "
Case 9
strS = "玖 "
Case Else
MsgBox "代码 fun金额大写() 的 Case 1 组 Case varK 段 Case Else 报告出错 ！", vbExclamation, "郑重提示"
Exit Function
End Select
strT = strT & strS
lngY = lngY + 1
Loop Until lngY = lngX + 1
Select Case lngX
Case 1
strF = "× × × × × × × × × " & strT & "× "
Case 2
strF = "× × × × × × × × × " & strT
Case Else
MsgBox "代码 fun金额大写() 的 Case 1 组 Case lngX 段 Case Else 报告出错 ！", vbExclamation, "郑重提示"
Exit Function
End Select
txt金额数字 = "." & varB
varH = "." & varB
txt金额大写 = "人民币" & strF & " ￥" & varH
Case Is > 1
varA = CLng(Mid(varM, 1, InStr(varM, ".") - 1))
If Len(varA) > 9 Then varA = Right(varA, 9)
lngV = Len(varA)
lngW = 1
Do
varJ = Mid(varA, lngW, 1)
Select Case varJ
Case 0
strQ = "零 "
Case 1
strQ = "壹 "
Case 2
strQ = "贰 "
Case 3
strQ = "叁 "
Case 4
strQ = "肆 "
Case 5
strQ = "伍 "
Case 6
strQ = "陆 "
Case 7
strQ = "柒 "
Case 8
strQ = "捌 "
Case 9
strQ = "玖 "
Case Else
MsgBox "代码 fun金额大写() 的 Case Is > 1 组 Select Case varJ 段 Case Else 报告出错 ！", vbExclamation, "郑重提示"
Exit Function
End Select
strR = strR & strQ
lngW = lngW + 1
Loop Until lngW = lngV + 1
Select Case lngV
Case 1
strE = "× × × × × × × × " & strR
Case 2
strE = "× × × × × × × " & strR
Case 3
strE = "× × × × × × " & strR
Case 4
strE = "× × × × × " & strR
Case 5
strE = "× × × × " & strR
Case 6
strE = "× × × " & strR
Case 7
strE = "× × " & strR
Case 8
strE = "× " & strR
Case 9
strE = strR
Case Else
MsgBox "代码 fun金额大写() 的 Case Is > 1 组 Select Case lngV 段 Case Else 报告出错 ！", vbExclamation, "郑重提示"
Exit Function
End Select
varB = Mid(varM, InStr(varM, ".") + 1)
If Len(varB) > 2 Then varB = Left(varB, 2)
lngX = Len(varB)
lngY = 1
Do
varK = Mid(varB, lngY, 1)
Select Case varK
Case 0
strS = "零 "
Case 1
strS = "壹 "
Case 2
strS = "贰 "
Case 3
strS = "叁 "
Case 4
strS = "肆 "
Case 5
strS = "伍 "
Case 6
strS = "陆 "
Case 7
strS = "柒 "
Case 8
strS = "捌 "
Case 9
strS = "玖 "
Case Else
MsgBox "代码 fun金额大写() 的 Case Is > 1 组 Select Case varK 段 Case Else 报告出错 ！", vbExclamation, "郑重提示"
Exit Function
End Select
strT = strT & strS
lngY = lngY + 1
Loop Until lngY = lngX + 1
Select Case lngX
Case 1
strF = strT & "× "
Case 2
strF = strT
Case Else
MsgBox "代码 fun金额大写() 的 Case Is > 1 组 Select Case lngX 段 Case Else 报告出错 ！", vbExclamation, "郑重提示"
Exit Function
End Select
txt金额数字 = varA & "." & varB
varH = Format(varA, "#,##0") & "." & varB
txt金额大写 = "人民币" & strE & strF & " ￥" & varH
Case Else
MsgBox "出现了可能与 小数点 相关的错误 ！", vbExclamation, "郑重提示"
Exit Function
End Select
Else
MsgBox "金额数字 不合规范 哦 ！", vbExclamation, "郑重提示"
txt金额大写 = Null
End If
End Function
Private Sub cmd关闭_Click()
On Error GoTo ErrorHandler
DoCmd.Close
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No：" & Err.Number & " Description：" & Err.Description
Resume ErrorHandlerExit
End Sub
|
