［上一页］（58）［下一页］

'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

［上一页］（58）［下一页］