VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)
首页 - 经验之谈 - VB问题全功略(28)
发表评论(0)作者:不详, 平台:VB6.0+Win98, 阅读:10977, 日期:2002-01-28
VB问题全功略(28)

136、找出电脑中已经安装的输入法
137、如何将一串阿拉伯数字转成中文数字字串?
138、如何将一串阿拉伯数字转成英文数字字串?
139、如何取得屏幕字体
140、如何得到某年每个月的第一天是星期几

136、找出电脑中已经安装的输入法

注释:在 Form 中加入一个 ListBox,在声明区中加入以下声明:

Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long

Private Declare Function ImmGetDescription Lib "imm32.dll" Alias "ImmGetDescriptionA" (ByVal HKL As Long, ByVal lpsz As String, ByVal uBufLen As Long) As Long

Private Declare Function ImmIsIME Lib "imm32.dll" (ByVal HKL As Long) As Long

注释:在 Form_Load 中加入以下程序码:

Private Sub Form_Load()
Dim No As Long, i As Long
Dim hKB(24) As Long, bufflen As Long
Dim buff As String, RetStr As String, RetCount As Long
buff = String(255, 0)
No = GetKeyboardLayoutList(25, hKB(0))
For i = 1 To No
If ImmIsIME(hKB(i - 1)) = 1 Then
bufflen = 255
RetCount = ImmGetDescription(hKB(i - 1), buff, bufflen)
RetStr = Left(buff, RetCount)
List1.AddItem RetStr
Else
RetStr = "English(American)"
List1.AddItem RetStr
End If
Next
End Sub

137、如何将一串阿拉伯数字转成中文数字字串?

在我们的应用系统中,有时候要产生一些比较正式的报表 (套表),例如合约书、电脑开票....等,在这些报表中,关于数字的部份,尤其是金额的部份,为了防止纠纷的产生,通常都必须将阿拉伯数字转成中文大写数字,这种工作,人工做起来很简单,电脑来做,可就要花点工夫了!

以下几个 Function 就是用来处理这个工作的,其中最主要的就是 numbertoword 这个 Function,程序中要呼叫的也就是这个 Function,其他三个 Function 只是配合这个 Function 而已。

注释:在程序中只要如右使用即可:返回中文数字 = numbertoword( 阿拉伯数字 )

程序码如下:

Public Function numbertoword(number As String) As String
注释:-------------------------------------------------------------------
注释:目的:转换一串阿拉伯数字为中文数字
注释:参数:一串阿拉伯数字
注释:返回值:转换后的一串中文数字
注释:---------------------------------------------------------------------------------------------------------------------------------
注释:注: 此一 Function 必须包含以下三个 Function
注释:1.mapword:转换单一数字为国数字(0123456789->零壹贰参肆伍陆柒捌玖)
注释:2.StringCleaner:清除字串中不要的字元
注释:3.convtoword:将传入的四个数字转成中文数字字串(1234->壹仟贰佰参拾肆)
注释:---------------------------------------------------------------------------------------------------------------------------------

Dim wlength As Integer 注释:数字字串总长度
Dim wsection As Integer 注释:归属的段落 (0:万以下/1:万/2:亿/3:兆)
Dim wcount As Integer 注释:剩余的数字字串长度
Dim wstr As String 注释:暂存字串
Dim wstr1 As String 注释:暂存字串-兆
Dim wstr2 As String 注释:暂存字串-亿
Dim wstr3 As String 注释:暂存字串-万
Dim wstr4 As String 注释:暂存字串-万以下

注释:未输入或0不做
注释:-----------------------------------------------
If Trim(number) = "" Or Trim(number) = "0" Then
numbertoword = "零"
Exit Function
End If
注释:-----------------------------------------------
wlength = Len(number)
wsection = wlength \ 4
wcount = wlength Mod 4
注释:-----------------------------------------------
注释:每四位一组, 分段 (兆/亿/万/万以下)
If wcount = 0 Then
wcount = 4
wsection = wsection - 1
End If
注释:----------------------------------------------
注释:大于兆的四位数转换
If wsection = 3 Then
注释:抓出大于兆的四位数
wstr = Left(Format(number, "0000000000000000"), 4)
注释:转换
wstr1 = convtoword(wstr)
If wstr1 <> "零" Then wstr1 = wstr1 & "兆"
End If
注释:----------------------------------------------
注释:大于亿的四位数转换
If wsection >= 2 Then
注释:抓出大于亿的四位数
If Len(number) > 12 Then
wstr = Left(Right(number, 12), 4)
Else
wstr = Left(Format(number, "000000000000"), 4)
End If
注释:转换
wstr2 = convtoword(wstr)
If wstr2 <> "零" Then wstr2 = wstr2 & "亿"
End If
注释:----------------------------------------------
注释:大于万的四位数转换
If wsection >= 1 Then
注释:抓出大于万的四位数
If Len(number) > 8 Then
wstr = Left(Right(number, 8), 4)
Else
wstr = Left(Format(number, "00000000"), 4)
End If
注释:转换
wstr3 = convtoword(wstr)
If wstr3 <> "零" Then wstr3 = wstr3 & "万"
End If
注释:----------------------------------------------
注释:万以下的四位数转换
注释:抓出万以下的四位数
If Len(number) > 4 Then
wstr = Right(number, 4)
Else
wstr = Format(number, "0000")
End If
注释:转换
wstr4 = convtoword(wstr)

注释:----------------------------------------------
注释:组合最多四组字串(兆/亿/万/万以下)
numbertoword = wstr1 & wstr2 & wstr3 & wstr4
注释:去除重复的零 (注释:零零注释:-->注释:零注释:)
Do While InStr(1, numbertoword, "零零")
numbertoword = StringCleaner(numbertoword, "零零")
Loop
注释:----------------------------------------------
注释:去除最左边的零
If Left(numbertoword, 1) = "零" Then
numbertoword = Mid(numbertoword, 2)
End If
注释:----------------------------------------------
注释:去除最右边的零
If Right(numbertoword, 1) = "零" Then
numbertoword = Mid(numbertoword, 1, Len(numbertoword) - 1)
End If
End Function


Public Function mapword(no As String) As String
注释:-----------------------------------------------------------
注释:目的:转换单一数字为国数字(0123456789->零壹贰参肆伍陆柒捌玖)
注释:参数:数字(0123456789)
注释:返回值:国数字(零壹贰参肆伍陆柒捌玖)
注释:-----------------------------------------------------------
Select Case no
Case "0"
mapword = "零"
Case 1
mapword = "壹"
Case "2"
mapword = "贰"
Case "3"
mapword = "参"
Case "4"
mapword = "肆"
Case "5"
mapword = "伍"
Case "6"
mapword = "陆"
Case "7"
mapword = "柒"
Case "8"
mapword = "捌"
Case "9"
mapword = "玖"
End Select
End Function

Public Function StringCleaner(s As String, Search As String) As String
注释:-----------------------------------------------------------
注释:目的:清除字串中不要的字元
注释:参数:1.完整字串. 2.要清除的字元(可含多字元)
注释:返回值:清除后的字串
注释:注释:注释:此段之主要目的在去除重复的 注释:零注释: (注释:零零注释:-->注释:零注释:)
注释:-----------------------------------------------------------
Dim i As Integer, res As String
res = s
Do While InStr(res, Search)
i = InStr(res, Search)
res = Left(res, i - 1) & Mid(res, i + 1)
Loop
StringCleaner = res
End Function

Public Function convtoword(wstr As String) As String
注释:-----------------------------------------------------------
注释:目的:将传入的四个数字转成中文数字字串(1234->壹仟贰佰参拾肆)
注释:参数:4位数的数字 (前面空白补0)
注释:返回值:转换后的中文数字字串
注释:-----------------------------------------------------------
Dim tempword As String
注释:仟位数
tempword = mapword(Mid(wstr, 1, 1))
If tempword <> "零" Then tempword = tempword & "仟"
convtoword = convtoword & tempword
注释:佰位数
tempword = mapword(Mid(wstr, 2, 1))
If tempword <> "零" Then tempword = tempword & "佰"
convtoword = convtoword & tempword
注释:拾位数
tempword = mapword(Mid(wstr, 3, 1))
If tempword <> "零" Then tempword = tempword & "拾"
convtoword = convtoword & tempword
注释:个位数
tempword = mapword(Mid(wstr, 4, 1))
convtoword = convtoword & tempword
注释:去除最右边的零
Do While Right(convtoword, 1) = "零" And Len(convtoword) > 1
convtoword = Mid(convtoword, 1, Len(convtoword) - 1)
Loop
End Function

注释:在程序中只要如右使用即可:返回中文数字 = numbertoword( 阿拉伯数字 )

注释:-----------------------------------------------------------
注释:程序中使用实例 ( 加上错误判断 )
注释:在 Form 中放二个 TextBox 及一个 CommandButton
注释:Text1 输入数字, Text2 显示转换结果
注释:-----------------------------------------------------------
Private Sub Command1_Click()
Text2 = ""
注释:去除小数点
If InStr(1, Text1, ".") <> 0 Then
Text1 = Mid(Text1, 1, InStr(1, Text1, ".") - 1)
End If
注释:去除逗点
Text1 = StringCleaner(Text1, ",")
注释:判断不含非数字
Dim i As Integer
Dim werr As String
For i = 1 To Len(Text1)
If Asc(Mid(Text1, i, 1)) < 48 Or Asc(Mid(Text1, i, 1)) > 57 Then
werr = "Y"
Exit For
End If
Next
If werr = "Y" Then
MsgBox "不可含非数字"
注释:focus 回到 text1 方便输入
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
Exit Sub
End If
注释:主要程序只一行-----------
Text2 = numbertoword(Text1)
注释:-------------------------
注释:focus 回到 text1 方便输入
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub

138、如何将一串阿拉伯数字转成英文数字字串?

在在同样情形下,有些情况,我们也必须将阿拉伯数字转成英文数字,以下这个 Function 就是用来处理这个工作的。

注释:在程序中只要如右使用即可:返回英文数字 = numtoword( 阿拉伯数字 )

先看看结果:

程序码如下:

Public Function numtoword(numstr As Variant) As String
注释:----------------------------------------------------
注释: The best data type to feed in is
注释: Decimal, but it is up to you
注释:----------------------------------------------------
Dim tempstr As String
Dim newstr As String
numstr = CDec(numstr)

If numstr = 0 Then
numtoword = "zero "
Exit Function
End If

If numstr > 10 ^ 24 Then
numtoword = "Too big"
Exit Function
End If

If numstr >= 10 ^ 12 Then
newstr = numtoword(Int(numstr / 10 ^ 12))
numstr = ((numstr / 10 ^ 12) - Int(numstr / 10 ^ 12)) * 10 ^ 12
If numstr = 0 Then
tempstr = tempstr & newstr & "billion "
Else
tempstr = tempstr & newstr & "billion, "
End If
End If

If numstr >= 10 ^ 6 Then
newstr = numtoword(Int(numstr / 10 ^ 6))
numstr = ((numstr / 10 ^ 6) - Int(numstr / 10 ^ 6)) * 10 ^ 6
If numstr = 0 Then
tempstr = tempstr & newstr & "million "
Else
tempstr = tempstr & newstr & "million, "
End If
End If

If numstr >= 10 ^ 3 Then
newstr = numtoword(Int(numstr / 10 ^ 3))
numstr = ((numstr / 10 ^ 3) - Int(numstr / 10 ^ 3)) * 10 ^ 3
If numstr = 0 Then
tempstr = tempstr & newstr & "thousand "
Else
tempstr = tempstr & newstr & "thousand, "
End If
End If

If numstr >= 10 ^ 2 Then
newstr = numtoword(Int(numstr / 10 ^ 2))
numstr = ((numstr / 10 ^ 2) - Int(numstr / 10 ^ 2)) * 10 ^ 2
If numstr = 0 Then
tempstr = tempstr & newstr & "hundred "
Else
tempstr = tempstr & newstr & "hundred and "
End If
End If

If numstr >= 20 Then
Select Case Int(numstr / 10)
Case 2
tempstr = tempstr & "twenty "
Case 3
tempstr = tempstr & "thirty "
Case 4
tempstr = tempstr & "forty "
Case 5
tempstr = tempstr & "fifty "
Case 6
tempstr = tempstr & "sixty "
Case 7
tempstr = tempstr & "seventy "
Case 8
tempstr = tempstr & "eighty "
Case 9
tempstr = tempstr & "ninety "
End Select
numstr = ((numstr / 10) - Int(numstr / 10)) * 10
End If

If numstr > 0 Then
Select Case numstr
Case 1
tempstr = tempstr & "one "
Case 2
tempstr = tempstr & "two "
Case 3
tempstr = tempstr & "three "
Case 4
tempstr = tempstr & "four "
Case 5
tempstr = tempstr & "five "
Case 6
tempstr = tempstr & "six "
Case 7
tempstr = tempstr & "seven "
Case 8
tempstr = tempstr & "eight "
Case 9
tempstr = tempstr & "nine "
Case 10
tempstr = tempstr & "ten "
Case 11
tempstr = tempstr & "eleven "
Case 12
tempstr = tempstr & "twelve "
Case 13
tempstr = tempstr & "thirteen "
Case 14
tempstr = tempstr & "fourteen "
Case 15
tempstr = tempstr & "fifteen "
Case 16
tempstr = tempstr & "sixteen "
Case 17
tempstr = tempstr & "seventeen "
Case 18
tempstr = tempstr & "eighteen "
Case 19
tempstr = tempstr & "nineteen "
End Select
numstr = ((numstr / 10) - Int(numstr / 10)) * 10
End If
numtoword = tempstr
End Function

注释:在程序中使用实例:Text1是输入的阿拉伯数字,Text2 是返回的英文字

Text2 = numtoword(Text1)
139、如何取得屏幕字体

Private Sub Combo1_Click()
Label1.Font = Combo1.List(Combo1.ListIndex)
End Sub

Private Sub Combo1_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub

Private Sub Command1_Click()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub

140、如何得到某年每个月的第一天是星期几

Private Sub Command1_Click()
Dim i As Integer, A As Integer, B As Integer, C As String
A = InputBox("请输入年份", "某年每个月的第一天是星期几")
Form1.Cls
For i = 1 To 12
C = A & "-" & i & "-1"
B = Weekday(C)
Select Case B
Case vbSunday
Print A & "年" & i & "月1日是 星期日"
Case vbMonday
Print A & "年" & i & "月1日是 星期一"
Case vbTuesday
Print A & "年" & i & "月1日是 星期二"
Case vbWednesday
Print A & "年" & i & "月1日是 星期三"
Case vbThursday
Print A & "年" & i & "月1日是 星期四"
Case vbFriday
Print A & "年" & i & "月1日是 星期五"
Case vbSaturday
Print A & "年" & i & "月1日是 星期六"
End Select
Next i

End Sub