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 |