VBGood网站全文搜索 Google

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

286、如何检查目录名是否有效?
287、如何将路径名和文件名拼装生成全路径名?
288、如何将数字转换为大写中文?
289、如何将一个文件转化为短名?
290、如何匹配RichTextBox框的查找下一个功能?

286、如何检查目录名是否有效?
注释:Function: IsPathValid(DestPath$, ByVal DefaultDrive$) As Integer
注释:Description: Checks for a valid path
注释:Returns: True/False
Function IsPathValid(DestPath$, ByVal DefaultDrive$) As Integer
Dim Tmp$, Drive$, LegalChar$, BackPos As Integer, ForePos As Integer
Dim Temp$, I As Integer, PeriodPos As Integer, Length As Integer
注释:-------------------------------------------------------
注释:- Remove left and right spaces
注释:-------------------------------------------------------
DestPath$ = RTrim$(LTrim$(DestPath$))
注释:-------------------------------------------------------
注释:- Check vbDefault Drive Parameter
注释:-------------------------------------------------------
If Right$(DefaultDrive$, 1) <> ":" Or Len(DefaultDrive$) <> 2 Then
MsgBox "Bad vbDefault drive parameter specified in IsPathValid Function. You passed, """ + DefaultDrive$ + """. Must be one drive letter and "":"". For example, ""C:"", ""D:""...", 64, "Setup Kit Error"
GoTo parseErr
End If
注释:-------------------------------------------------------
注释:- Insert vbDefault drive if path begins with root backslash
注释:-------------------------------------------------------
If Left$(DestPath$, 1) = "\" Then
DestPath$ = DefaultDrive + DestPath$
End If
注释:-------------------------------------------------------
注释:- check for invalid characters
注释:-------------------------------------------------------
On Error Resume Next
Tmp$ = Dir$(DestPath$)
If Err <> 0 Then
GoTo parseErr
End If
注释:-------------------------------------------------------
注释:- Check for wildcard characters and spaces
注释:-------------------------------------------------------
If (InStr(DestPath$, "*") <> 0) Then GoTo parseErr
If (InStr(DestPath$, "?") <> 0) Then GoTo parseErr
If (InStr(DestPath$, " ") <> 0) Then GoTo parseErr
注释:-------------------------------------------------------
注释:- Make Sure colon is in second char position
注释:-------------------------------------------------------
If Mid$(DestPath$, 2, 1) <> Chr$(58) Then GoTo parseErr
注释:-------------------------------------------------------
注释:- Insert root backslash if needed
注释:-------------------------------------------------------
If Len(DestPath$) > 2 Then
If Right$(Left$(DestPath$, 3), 1) <> "\" Then
DestPath$ = Left$(DestPath$, 2) + "\" + Right$(DestPath$, Len(DestPath$) - 2)
End If
End If
注释:-------------------------------------------------------
注释:- Check drive to install on
注释:-------------------------------------------------------
Drive$ = Left$(DestPath$, 1)
ChDrive (Drive$) 注释: Try to change to the dest drive
If Err <> 0 Then GoTo parseErr
注释:-------------------------------------------------------
注释:- Add final \
注释:-------------------------------------------------------
If Right$(DestPath$, 1) <> "\" Then
DestPath$ = DestPath$ + "\"
End If
注释:-------------------------------------------------------
注释:- Root dir is a valid dir
注释:-------------------------------------------------------
If Len(DestPath$) = 3 Then
If Right$(DestPath$, 2) = ":\" Then
GoTo ParseOK
End If
End If
注释:-------------------------------------------------------
注释:- Check for repeated Slash
注释:-------------------------------------------------------
If InStr(DestPath$, "\\") <> 0 Then GoTo parseErr
注释:-------------------------------------------------------
注释:- Check for illegal directory names
注释:-------------------------------------------------------
LegalChar$ = "!#$%&注释:()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~.?"
BackPos = 3
ForePos = InStr(4, DestPath$, "\")
Do
Temp$ = Mid$(DestPath$, BackPos + 1, ForePos - BackPos - 1)
注释:-------------------------------------------------------
注释:- Test for illegal characters
注释:-------------------------------------------------------
For I = 1 To Len(Temp$)
If InStr(LegalChar$, UCase$(Mid$(Temp$, I, 1))) = 0 Then GoTo parseErr
Next I
注释:-------------------------------------------------------
注释:- Check combinations of periods and lengths
注释:-------------------------------------------------------
PeriodPos = InStr(Temp$, ".")
Length = Len(Temp$)
If PeriodPos = 0 Then
If Length > 8 Then GoTo parseErr 注释: Base too long
Else
If PeriodPos > 9 Then GoTo parseErr 注释: Base too long
If Length > PeriodPos + 3 Then GoTo parseErr 注释: Extension too long
If InStr(PeriodPos + 1, Temp$, ".") <> 0 Then GoTo parseErr 注释: Two periods not allowed
End If
BackPos = ForePos
ForePos = InStr(BackPos + 1, DestPath$, "\")
Loop Until ForePos = 0
ParseOK:
IsPathValid = True
Exit Function
parseErr:
IsPathValid = False
End Function

287、如何将路径名和文件名拼装生成全路径名?

Function AddPathToFile(ByVal sPathIn As String, ByVal sFileNameIn As String) As String
注释:RETURNS: Path concatenated to File.
Dim sPath As String
Dim sFileName As String
注释:Remove any leading or trailing spaces
sPath = Trim$(sPathIn)
sFileName = Trim$(sFileNameIn)
If sPath = "" Then
AddPathToFile = sFileName
Else
If Right$(sPath, 1) = "\" Then
AddPathToFile = sPath & sFileName
Else
AddPathToFile = sPath & "\" & sFileName
End If
End If
End Function

288、如何将数字转换为大写中文?

这个读数程序可以支持无限长有限小数,希望大家一测:
Const strN = "零壹贰叁肆伍陆柒捌玖"
Const strG = "拾佰仟万亿"
Const intN = "0123456789"
Dim Zero_Count As Long 注释:读零计数
注释:
Private Function GetN(ByVal N As Long) As String
GetN = Mid(strN, N + 1, 1)
End Function
Private Function GetG(ByVal G As Long) As String
Select Case G
Case 1
GetG = ""
Case 2, 6
GetG = Mid(strG, 1, 1)
Case 3, 7
GetG = Mid(strG, 2, 1)
Case 4, 8
GetG = Mid(strG, 3, 1)
Case 5
GetG = Mid(strG, 4, 1)
Case 9
GetG = Mid(strG, 5, 1)
End Select
End Function
Private Function ReadLongNumber(ByVal LongX As String) As String
Dim NumberX As String
Dim l As Long 注释:长度
Dim m As Long 注释:多余位数
Dim c As Long 注释:循环次数
Dim i As Long, j As Long 注释:标志
Dim CurN As String
NumberX = LongX
l = Len(NumberX)
Do Until l < 9
m = l Mod 8
If m = 0 Then m = 8
CurN = Left(NumberX, m)
If ReadIntNumber(CurN) <> "零" Then
ReadLongNumber = ReadLongNumber & ReadIntNumber(CurN) & "亿"
Else
ReadLongNumber = ReadLongNumber & "亿"
End If
NumberX = Right(NumberX, Len(NumberX) - m)
l = Len(NumberX)
Loop
ReadLongNumber = ReadLongNumber & ReadIntNumber(NumberX)
If Len(ReadLongNumber) > 2 And Right(ReadLongNumber, 1) = "零" Then 注释:去尾 零
ReadLongNumber = Left(ReadLongNumber, Len(ReadLongNumber) - 1)
End If
If Mid(ReadLongNumber, 1, 2) = "壹拾" Then 注释:掐头 壹拾
ReadLongNumber = Right(ReadLongNumber, Len(ReadLongNumber) - 1)
Mid(ReadLongNumber, 1, 1) = "拾"
End If
Zero_Count = 0
End Function
Private Function ReadIntNumber(ByVal NumberX As String) As String
Dim l As Long 注释:长度
Dim m As Long 注释:多余位数
Dim c As Long 注释:循环次数
Dim i As Long, j As Long 注释:标志
Dim CurN As String
If Val(NumberX) = 0 Then ReadIntNumber = GetN(0): Exit Function
l = Len(NumberX)
If l > 8 Then Exit Function
m = l Mod 9
CurN = Right(NumberX, m)
For i = Len(CurN) To 1 Step -1
If GetN(Int(Mid(CurN, i, 1))) = "零" And Zero_Count = 1 Then
If GetG(Len(CurN) - i + 1) = "万" Then
If (Not (Val(Left(CurN, Len(CurN) - 5)) = 0)) Then ReadIntNumber = GetG(Len(CurN) - i + 1) & ReadIntNumber
End If
Else
If GetN(Int(Mid(CurN, i, 1))) = "零" Then
ReadIntNumber = GetN(Int(Mid(CurN, i, 1))) & ReadIntNumber
If GetG(Len(CurN) - i + 1) = "万" Then
If (Not (Val(Left(CurN, Len(CurN) - 5)) = 0)) Then ReadIntNumber = GetG(Len(CurN) - i + 1) & ReadIntNumber
End If
Zero_Count = 1
Else
ReadIntNumber = GetG(Len(CurN) - i + 1) & ReadIntNumber
ReadIntNumber = GetN(Int(Mid(CurN, i, 1))) & ReadIntNumber
Zero_Count = 0
End If
End If
Next i
注释:Loop
If Len(ReadIntNumber) > 2 And Right(ReadIntNumber, 1) = "零" Then 注释:去尾 零
ReadIntNumber = Left(ReadIntNumber, Len(ReadIntNumber) - 1)
End If
If Mid(ReadIntNumber, 1, 2) = "壹拾" Then 注释:掐头 壹拾
ReadIntNumber = Right(ReadIntNumber, Len(ReadIntNumber) - 1)
Mid(ReadIntNumber, 1, 1) = "拾"
End If
End Function
Public Function ReadNumber(ByVal NumberX As String) As String
Dim LongX As String
Dim PointX As String
Dim LongLong As Long
Dim bFS As Boolean 注释:负数
If Not IsNumeric(NumberX) Then
ReadNumber = ""
Exit Function
End If
If CDbl(NumberX) < 0 Then
NumberX = -NumberX
bFS = True
End If
NumberX = CStr(Format(NumberX, "General Number"))
LongLong = InStr(1, NumberX, ".")
If LongLong <> 0 Then
ReadNumber = ReadLongNumber(Left(NumberX, LongLong - 1))
ReadNumber = ReadNumber & "点" & ReadSmallNumber(Right(NumberX, Len(NumberX) - LongLong))
Else
ReadNumber = ReadLongNumber(NumberX)
End If
If bFS = True Then
ReadNumber = "负" & ReadNumber
End If
End Function
Private Function ReadSmallNumber(SmallNumber As String) As String
Dim i As Long
For i = 1 To Len(SmallNumber)
ReadSmallNumber = ReadSmallNumber & GetN(Mid(SmallNumber, i, 1))
Next i
End Function
Private Function ReadSmallNumberToRMB(SmallNumber As String) As String
ReadSmallNumberToRMB = GetN(Mid(SmallNumber, 1, 1)) & "角" & GetN(Mid(SmallNumber, 2, 1)) & "分"
End Function
Public Function ReadNumberToRMB(ByVal NumberX As String) As String
Dim LongX As String
Dim PointX As String
Dim LongLong As Long
Dim bFS As Boolean 注释:负数
If Not IsNumeric(NumberX) Then
ReadNumberToRMB = ""
Exit Function
End If
If CDbl(NumberX) < 0 Then
NumberX = -NumberX
bFS = True
End If
NumberX = CStr(Format(NumberX, "#.00"))
LongLong = InStr(1, NumberX, ".")
If Right(NumberX, Len(NumberX) - LongLong) <> "" Then
ReadNumberToRMB = ReadLongNumber(Left(NumberX, LongLong - 1))
ReadNumberToRMB = ReadNumberToRMB & "元" & ReadSmallNumberToRMB(Right(NumberX, Len(NumberX) - LongLong))
Else
ReadNumberToRMB = ReadLongNumber(NumberX)
End If
If bFS = True Then
ReadNumberToRMB = "负" & ReadNumberToRMB
End If
End Function

289、如何将一个文件转化为短名?

Option Explicit
注释:API calls for long filename support
Declare Function LoadLibraryEx32W Lib "Kernel" (ByVal lpszFile As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Declare Function FreeLibrary32W Lib "Kernel" (ByVal hDllModule As Long) As Long
Declare Function GetProcAddress32W Lib "Kernel" (ByVal hInstance As Long, ByVal FunctionName As String) As Long
Declare Function FindFirstFileA Lib "Kernel" Alias "CallProc32W" (ByVal lpszFile As String, aFindFirst As WIN32_FIND_DATA, ByVal lpfnFunction As Long, ByVal fAddressConvert As Long, ByVal dwParams As Long) As Long
Declare Function GetShortPathNameA Lib "Kernel" Alias "CallProc32W" (ByVal lpszLongFile As String, ByVal lpszShortFile As String, ByVal lBuffer As Long, ByVal lpfnFunction As Long, ByVal fAddressConvert As Long, ByVal dwParams As Long) As Long
Declare Function lcreat Lib "Kernel" Alias "_lcreat" (ByVal lpPathName As String, ByVal iAttribute As Integer) As Integer
Private hInstKernel As Long
Private lpGetShortPathNameA As Long
Private lpFindFirstFileA As Long
注释:Define structures for api calls
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Const MAX_PATH = 260
Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Function GetShortFilename(Filename As String) As String
注释:=========================================================
注释:Returns the ShortFileName of a file if in a 32 bit system
注释:Else returns Filename. You MUST check the validity of the
注释:filename after this function. If this function fails, it
注释:will return the long filename it was passed.
注释:=========================================================
On Error GoTo GetShortFilename_Error
Dim sFF As WIN32_FIND_DATA
Dim a As Long
Dim szShortFilename As String * 256
Dim p As Integer
注释:Load Kernel32 DLL - if you are on a 16 bit system this is where it would fail
hInstKernel = LoadLibraryEx32W("Kernel32.dll", 0&, 0&)
注释:Addresses of the long filename functions
lpGetShortPathNameA = GetProcAddress32W(hInstKernel, "GetShortPathNameA")
注释:Get the short name for the directory
a = GetShortPathNameA(Filename, szShortFilename, 256&, lpGetShortPathNameA, 6&, 3&)
p = InStr(szShortFilename, Chr$(0))
Filename = LCase$(Left$(szShortFilename, p - 1))
GetShortFilename = Filename
注释:Release the Kernel if necessary
a = FreeLibrary32W(hInstKernel)
Exit Function
GetShortFilename_Error:
注释: must be no Win32 support, so just return the passed in filename
GetShortFilename = Filename
Exit Function
End Function

290、如何匹配RichTextBox框的查找下一个功能?

Private Sub FindNext()
Dim nPosition As Long
Dim strTemp As String
注释:如果文本中已有加亮的字符则将光标后移一位
If txtContext.SelLength > 0 Then txtContext.SelStart = txtContext.SelStart + 1
注释:将当前光标以前的字符串取出
strTemp = Left(txtContext.Text, txtContext.SelStart)
注释:最中英文混合字符串的长度(中文相当于两个英文)
nPosition = LenB(StrConv(strTemp, vbFromUnicode))
注释:下面一行的目的是为了从第一个字符开始搜索
If nPosition = 0 Then nPosition = -1
注释:后移一位以防搜索到自已
nPosition = txtContext.Find(FrmSearch.txtSearch.Text, nPosition + 1)
If nPosition = -1 Then 注释:nPosition=-1表示没有找到
If MsgBox(" 本次搜索没有找到匹配字符串, 从头开始吗? ", vbQuestion + vbYesNo, "") = vbYes Then
txtContext.SelStart = 0
FindNext
Exit Sub
End If
End If
End If