登录  
 加关注
查看详情
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

面包会有的

... ...

 
 
 

日志

 
 

VB使用大全 - 8  

2007-09-08 14:34:21|  分类: 默认分类 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

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

141、在 VB 程序中做复制磁片 (DiskCopy) 的功能
下面这一段程序并不是实际在程序中就做复制磁片的功能,而是呼叫出 Windows 系统的复制磁片问话框!
'在声明区中加入以下声明
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'在 Form 中加入一个 CommandButton 命名为 cmdDiskCopy,再加入一个 DriveListBox
Private Sub cmdDiskCopy_Click()
' DiskCopyRunDll takes two parameters- From and To
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg&
DriveLetter = UCase(Drive1.Drive) '磁盘代号 ( A / B / C / D..... )
DriveNumber = (Asc(DriveLetter) - 65) '磁盘序号,从 0 开始:A=0,B=1....
DriveType = GetDriveType(DriveLetter) '磁盘型态 ( 软盘 / 硬盘 / 光盘 ... )
If DriveType = 2 Then '软盘
RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll " & DriveNumber & "," & DriveNumber, 1) 'Notice space after
Else '非软盘
RetFromMsg = MsgBox("只有磁盘片才可以复制磁片", 64, "复制磁片")
End If
End Sub
142、在 VB 程序中做制作格式 (Format) 的功能
下面这一段程序并不是实际在程序中就做制作格式的功能,而是呼叫出 Windows 系统的制作格式问话框!
这个范例程序是从网络上抓下来的,原作者特别注明,这一段程序也可以格式化硬盘,所以要小心控制,程序码中格式化硬盘的部份,我已经 Mark 起来了,若有需要,才将 Mark 拿掉吧!
软盘格式化的部份我已测试过没问题,硬盘的部份,我没有空硬盘所以没有测试,大家自己玩玩吧!若有问题再通知我!
'在声明区中加入以下声明
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'在 Form 中加入一个 CommandButton 命名为 cmdFormatDrive,再加入一个 DriveListBox
Private Sub cmdFormatDrive_Click()
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg%
DriveLetter = UCase(Drive1.Drive) '磁盘代号 ( A / B / C / D..... )
DriveNumber = (Asc(DriveLetter) - 65) '磁盘序号,从 0 开始:A=0,B=1....
DriveType = GetDriveType(DriveLetter) '磁盘型态 ( 软盘 / 硬盘 / 光盘 ... )
If DriveType = 2 Then '软盘
RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Else '非软盘
RetFromMsg = MsgBox("这一张磁盘不是软盘,可能是硬盘!" & vbCrLf & _
"您还要继续格式 (Format) 吗?", 276, "格式化")
Select Case RetFromMsg
Case 6 'Yes:表示要格式化硬盘
' UnComment to do it...
'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Case 7 'No:表示要取消格式化
' Do nothing
End Select
End If
End Sub
143、简简单单做到【剪下 / 复制 / 贴上 / 复原】的功能
在很多软件的编辑功能表中,都有提供【剪下 / 复制 / 贴上 / 复原】的功能,在 VB 中我们只要借用 Windows 的系统功能,很容易也可以有这样的功能,看看以下的程序码便能了解了!
Sub mnuEditText_Click (Index As Integer)
' 我们只要使用 SendKeys,其他的就让 Windows 去做吧!
Select Case Index
Case 0 '复原/UNDO
SendKeys "^Z" 'Keys Ctrl+Z
Case 1 '剪下/CUT
SendKeys "^X" 'Keys Ctrl+X
Case 2 '复制/COPY
SendKeys "^C" 'Keys Ctrl+C
Case 3 '贴上/PASTE
SendKeys "^V" 'Keys Ctrl+V
End Select
End Sub
144、如何侦测电脑目前是否正在连线中?
有些应用程序在程序中有部份功能必须和 Internet 连结沟通,这时候,侦测电脑目前是否正在连线状态就显得很重要了,每当在 Windows 中拨接上网之后,Windows 系统会自动在注册表中做上一点记号 (改变注册表中某些键值的资料),而我们在 VB 程序中就可以利用这些改变的键值来判断电脑目前是否正在连线状态!
'在模组的声明区中加入以下声明及模组:
Public Const ERROR_SUCCESS = 0&
Public Const APINULL = 0&
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public ReturnCode As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Function ActiveConnection() As Boolean
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
ActiveConnection = False
lpSubKey = "System\CurrentControlSet\Services\RemoteAccess"
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, phkResult)
If ReturnCode = ERROR_SUCCESS Then
hKey = phkResult
lpValueName = "Remote Connection"
lpReserved = APINULL
lpType = APINULL
lpData = APINULL
lpcbData = APINULL
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, ByVal lpData, lpcbData)
lpcbData = Len(lpData)
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, lpData, lpcbData)
If ReturnCode = ERROR_SUCCESS Then
If lpData = 0 Then
ActiveConnection = False
Else
ActiveConnection = True
End If
End If
RegCloseKey (hKey)
End If
End Function
而在程序中使用实例如下:
If ActiveConnection = True then
Call MsgBox("您的电脑目前正在连线中!",vbInformation)
Else
Call MsgBox("您的电脑目前在离线状态!.", vbInformation)
End If
145、如何在程序中启动【拨号网络连线】对话框?
要直接在 VB 程序中开启【拨号网络连线】对话框,要使用 Shell 函数:
Private Sub Command1_Click()
Dim res
res = Shell("rundll32.exe rnaui.dll,RnaDial " & "拨号网络连线名称", 1)
End Sub
其中 "拨号网络连线名称" 是我们事先在 【拨号网络】中设定的【连线名称】,例如【Hinet】。
注:以上方法只适用于 Windows95/98。

146、如何中断【拨号网路连线】?

要在 VB 程序中中断【拨号网路连线】,可以使用 Remote Access Services Hangup 函数:

'在模组的声明区中加入以下声明及模组:

Public Const RAS_MAXENTRYNAME As Integer = 256
Public Const RAS_MAXDEVICETYPE As Integer = 16
Public Const RAS_MAXDEVICENAME As Integer = 128
Public Const RAS_RASCONNSIZE As Integer = 412
Public Const ERROR_SUCCESS = 0&

Public Type RasEntryName
dwSize As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
End Type

Public Type RasConn
dwSize As Long
hRasConn As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
szDeviceType(RAS_MAXDEVICETYPE) As Byte
szDeviceName(RAS_MAXDEVICENAME) As Byte
End Type

Public Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long

Public Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long

Public gstrISPName As String
Public ReturnCode As Long

Public Sub HangUp()
Dim i As Long
Dim lpRasConn(255) As RasConn
Dim lpcb As Long
Dim lpcConnections As Long
Dim hRasConn As Long

lpRasConn(0).dwSize = RAS_RASCONNSIZE
lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize
lpcConnections = 0
ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)
If ReturnCode = ERROR_SUCCESS Then
For i = 0 To lpcConnections - 1
If Trim(ByteToString(lpRasConn(i).szEntryName)) = Trim(gstrISPName) Then
hRasConn = lpRasConn(i).hRasConn
ReturnCode = RasHangUp(ByVal hRasConn)
End If
Next i
End If
End Sub

Public Function ByteToString(bytString() As Byte) As String
Dim i As Integer
ByteToString = ""
i = 0
While bytString(i) = 0&
ByteToString = ByteToString & Chr(bytString(i))
i = i + 1
Wend
End Function

'在程序中使用实例为

Call HangUp

  评论这张
 
阅读(596)| 评论(0)

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2018