VERSION 1.0 CLASSBEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObjectENDAttribute VB_Name = "HouZi"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = FalseOption Explicit'====================================================================='更新记录'侯叔敏 2006.12.15 创建'====================================================================='属性相关' 1.P_LogFile 操作记录的文件路径(注：要求绝对路径)' 2.RegEx_String 正则表达式 匹配方式 属性处理' 3.P_From_Path 源文件夹 属性处理' 4.P_To_Path 目标文件夹 属性处理' 5.Tag 备注 属性处理' 6.P_FileName 文件名 属性处理'====================================================================='事件相关' 1.TravelFolderFileProcess(strFileName As String)' 2.TravelFileLineProcess(strCurrentLine As String, lngCurrentLineNo As Long)'====================================================================='方法相关' 1.TravelFile()' 功能 遍历 P_From_Path(源文件夹)内的 P_FileName(文件名) 的每一行数据 并用TravelFileLineProcess 事件处理' 2.TravelFolder()' 功能 遍历 P_From_Path(源文件夹)内的每一个文件，并用 TravelFolderFileProcess 事件处理' 3.fDelInvaildChr()' 功能 去掉文件名内的无效字符' 参数1 strFileName' 4.ValidateString()' 功能 正则表达式匹配' 参数1 strPatternIn' 参数2 strContent' 5.FileExists()' 功能 判断文件或文件夹是否存在 ''(注意文件名不能超过128)' 参数1 strFileName' 6.ConvertToCrLf' 功能 使用 0D0A 重构文本文件即回车换行 注意：非文本文件请不要使用此功能' 参数1 strFileName' 7.ConvertToLf' 功能 使用 0A 重构文本文件即换行 注意：非文本文件请不要使用此功能' 参数1 strFileName' 8.INI_Read' 功能 通过 API 读取 INI 文件' 参数1 SectionName' 参数2 KeyName' 参数3 INIPath' 参数4 DefaultValue' 9.INI_Write' 功能 通过 API 保存 INI 文件' 参数1 SectionName' 参数2 KeyName' 参数3 Value' 参数4 INIPath' 参数5 blnDeleteKeyIfBlank' 10.IsArrayEmpty()' 功能 判断变量是不是空的array型数据' 参数1 varTemp' 11.Convert_Date()' 功能 返回一个以 strSplitChar 为分隔符的年月日的日期格式,默认返回当前日期(注:如果传入日期小于1900-01-01 则取当前日期)' 参数1 dateTemp' 参数2 strSplitChar' 12.Convert_Time()' 功能 返回一个以 strSplitChar 为分隔符的时分秒的时间格式,默认返回当前时间(注:如果传入日期小于1900-01-01 则取当前时间)' 参数1 dateTemp' 参数2 strSplitChar' 13.File_Copy()' 功能 将文件 strSource 拷贝到 strDesctation ,并判断文件是否拷贝成功,如果存在并自动覆盖' 参数1 strExistingFileName' 参数2 NewFileName' 14.File_Move()' 功能 将文件 strSource 移动到 strDesctation ,并判断文件是否移动成功' 参数1 strExistingFileName' 参数2 NewFileName' 15 File_Append()' 功能 将 strContent 的内容写入到 strfilename' 参数1 strFileName' 参数2 strContent' 参数3 CrlfFlag'=====================================================================Private Const MAX_PATH = 260Private Const OFS_MAXPATHNAME = 128Private Const OF_EXIST = &H4000Private Const MOVEFILE_REPLACE_EXISTING = &H1Private Const MOVEFILE_COPY_ALLOWED = &H2Private Type FILETIME dwLowDateTime As Long dwHighDateTime As LongEnd TypePrivate 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 * 14End TypePrivate Type OFSTRUCT cBytes As Byte fFixedDisk As Byte nErrCode As Integer Reserved1 As Integer Reserved2 As Integer szPathName(OFS_MAXPATHNAME) As ByteEnd TypePrivate Declare Function apiOpenFile Lib "kernel32" Alias "OpenFile" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As LongPrivate Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As LongPrivate Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As LongPrivate Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As LongPrivate Declare Function GetPrivateProfileString Lib "kernel32.dll" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As LongPrivate Declare Function WritePrivateProfileString Lib "kernel32.dll" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal LPString As String, ByVal lpFileName As String) As LongPrivate Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As LongPrivate Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As LongPrivate Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As LongPublic Event TravelFolderFileProcess(strFileName As String)Public Event TravelFileLineProcess(strCurrentLine As String, lngCurrentLineNo As Long)Private HouZi_From_Path As StringPrivate HouZi_To_Path As StringPrivate HouZi_RegEx_String As StringPrivate HouZi_Tag As StringPrivate HouZi_FileName As StringPrivate Houzi_LogFile As StringPrivate Houzi_State As String'=====================================================================' 类初始化'=====================================================================Private Sub Class_Initialize() Houzi_LogFile = App.Path + "/Sys_Log_" + Replace(Replace(Date, "/", ""), "-", "") + ".log"End Sub'=====================================================================' 当前操作状态'=====================================================================Public Property Get P_State() As String P_State = Houzi_StateEnd PropertyPublic Property Let P_State(strState As String) If strState <> "" Then Houzi_State = strState End IfEnd Property'=====================================================================' 操作记录的文件路径(注：要求绝对路径)'=====================================================================Public Property Get P_LogFile() As String P_LogFile = Houzi_LogFileEnd PropertyPublic Property Let P_LogFile(Absolute_Path As String) If Absolute_Path <> "" Then Houzi_LogFile = Absolute_Path End IfEnd Property'=====================================================================' 正则表达式 匹配方式 属性处理'=====================================================================Public Property Get RegEx_String() As String RegEx_String = HouZi_RegEx_StringEnd PropertyPublic Property Let RegEx_String(strPatternIn As String) If strPatternIn <> "" Then HouZi_RegEx_String = strPatternIn End IfEnd Property'=====================================================================' 源文件夹 属性处理'=====================================================================Public Property Get P_From_Path() As String P_From_Path = HouZi_From_PathEnd PropertyPublic Property Let P_From_Path(strFromFolder As String) If strFromFolder <> "" Then HouZi_From_Path = strFromFolder End IfEnd Property'=====================================================================' 目标文件夹 属性处理'=====================================================================Public Property Get P_To_Path() As String P_To_Path = HouZi_To_PathEnd PropertyPublic Property Let P_To_Path(strToFolder As String) If strToFolder <> "" Then HouZi_To_Path = strToFolder End IfEnd Property'=====================================================================' 备注 属性处理'=====================================================================Public Property Get Tag() As String Tag = HouZi_TagEnd PropertyPublic Property Let Tag(strTemp As String) If strTemp <> "" Then HouZi_Tag = strTemp End IfEnd Property'=====================================================================' 文件名 属性处理'=====================================================================Public Property Get P_FileName() As String P_FileName = HouZi_FileNameEnd PropertyPublic Property Let P_FileName(Only_FileName As String) If Only_FileName <> "" Then HouZi_FileName = Only_FileName End IfEnd Property'=====================================================================' 去掉文件名内的无效字符'=====================================================================Public Function fDelInvaildChr(strFileName As String) As String 'on error resume next Dim I As Long For I = Len(strFileName) To 1 Step -1 If Asc(Mid(strFileName, I, 1)) <> 0 And Asc(Mid(strFileName, I, 1)) <> 32 Then fDelInvaildChr = Left(strFileName, I) Exit For End If NextEnd Function'=====================================================================' 正则表达式匹配'=====================================================================Public Function ValidateString(strPatternIn As String, strContent As String) As Boolean 'on error resume next Dim blnMatche As Boolean Dim regEx As New RegExp '建立正则表达式。 regEx.IgnoreCase = True '设置是否区分字符大小写。 regEx.Global = True '设置全局可用性。 regEx.Pattern = strPatternIn '设置模式。 blnMatche = regEx.Test(strContent) ValidateString = blnMatche Set regEx = NothingEnd Function'=====================================================================' 判断文件或文件夹是否存在(注意文件名不能超过128)'=====================================================================Public Function FileExists(ByVal strFileName As String) As Boolean 'on error resume next'使用 api pathfileexists 会用到 shlwapi.dll 系统文件 If Len("" & strFileName) > 3 Then FileExists = CBool(PathFileExists(strFileName)) Else FileExists = False End If'使用 apiopenfile 但有128限制' Dim typOfStruct As OFSTRUCT' If Len(strFileName) > 0 And LenB(strFileName) <= 128 Then' apiOpenFile strFileName, typOfStruct, OF_EXIST' FileExists = typOfStruct.nErrCode <> 2' End IfEnd Function'=====================================================================' 使用 0D0A 重构文本文件即回车换行' 注意：非文本文件请不要使用此功能'=====================================================================Public Function ConvertToCrLf(strFileName As String) 'on error resume next Dim intFileNum As Integer Dim strTemp As String intFileNum = FreeFile Open strTemp + HouZi_FileName For Binary As #intFileNum strTemp = Space(LOF(intFileNum)) Get intFileNum, , strTemp Close #intFileNum strTemp = Replace(strTemp, vbCrLf, vbLf) strTemp = Replace(strTemp, vbCr, vbLf) strTemp = Replace(strTemp, vbLf, vbCrLf) intFileNum = FreeFile Open strFileName For Output As #intFileNum Print #intFileNum, strTemp; Close #intFileNumEnd Function'=====================================================================' 使用 0A 重构文本文件即换行' 注意：非文本文件请不要使用此功能'=====================================================================Public Function ConvertToLf(strFileName As String) 'on error resume next Dim intFileNum As Integer Dim strTemp As String intFileNum = FreeFile Open strTemp + HouZi_FileName For Binary As #intFileNum strTemp = Space(LOF(intFileNum)) Get intFileNum, , strTemp Close #intFileNum strTemp = Replace(strTemp, vbCr, "") Open strFileName For Output As #intFileNum Print #intFileNum, strTemp; Close #intFileNumEnd Function'=====================================================================' 通过 API 读取 INI 文件'=====================================================================Public Function INI_Read(ByVal SectionName As String, ByVal KeyName As String, ByVal INIPath As String, Optional ByVal DefaultValue As String = "") As String On Error Resume Next Dim lngLength As Long If FileExists(INIPath) Then INI_Read = String(MAX_PATH, Chr(0)) lngLength = GetPrivateProfileString(SectionName & Chr(0), KeyName & Chr(0), DefaultValue & Chr(0), INI_Read, Len(INI_Read), INIPath & Chr(0)) INI_Read = Left(INI_Read, lngLength) Else End IfEnd Function'=====================================================================' 通过 API 保存 INI 文件'=====================================================================Public Function INI_Write(ByVal SectionName As String, ByVal KeyName As String, ByVal Value As String, ByVal INIPath As String, Optional ByVal blnDeleteKeyIfBlank As Boolean = False) As Boolean On Error Resume Next If blnDeleteKeyIfBlank = True Then If SectionName = "" Then SectionName = vbNullString Else SectionName = SectionName & Chr(0) End If If KeyName = "" Then KeyName = vbNullString Else KeyName = KeyName & Chr(0) End If If Value = "" Then Value = vbNullString Else Value = Value & Chr(0) End If Else SectionName = SectionName & Chr(0) KeyName = KeyName & Chr(0) Value = Value & Chr(0) End If If WritePrivateProfileString(SectionName, KeyName, Value, INIPath & Chr(0)) <> 0 Then INI_Write = True End IfEnd Function'=====================================================================' 判断变量是不是空的array型数据'=====================================================================Public Function IsArrayEmpty(varTemp As Variant) As Boolean Dim lngTemp As Long On Error Resume Next lngTemp = LBound(varTemp, 1) IsArrayEmpty = (Err <> 0) Err = 0End Function'=====================================================================' 返回一个以strTemp为分隔符的年月日的日期格式,默认返回当前日期(注:如果传入日期小于1900-01-01 则取当前日期)'=====================================================================Public Function Convert_Date(Optional dateTemp As Date, Optional strSplitChar As String = "-") As String If dateTemp < CDate("1900-01-01") Then dateTemp = Date End If Convert_Date = CStr(Year(dateTemp)) + strSplitChar + Right("00" + CStr(Month(dateTemp)), 2) + strSplitChar + Right("00" + CStr(Day(dateTemp)), 2)End Function'=====================================================================' 返回一个以strTemp为分隔符的时分秒的时间格式,默认返回当前时间(注:如果传入日期小于1900-01-01 则取当前时间)'=====================================================================Public Function Convert_Time(Optional dateTemp As Date, Optional strSplitChar As String = ":") As String If dateTemp < CDate("1900-01-01") Then dateTemp = Now() End If Convert_Time = Right("00" + CStr(Hour(dateTemp)), 2) + strSplitChar + Right("00" + CStr(Minute(dateTemp)), 2) + strSplitChar + Right("00" + CStr(Second(dateTemp)), 2)End Function'=====================================================================' 将文件 strSource 拷贝到 strDesctation ,并判断文件是否拷贝成功,如果存在并自动覆盖'=====================================================================Public Function File_Copy(strExistingFileName As String, NewFileName As String) As Boolean 'On Error Resume Next Dim lngTemp As Long lngTemp = CopyFile(strExistingFileName, NewFileName, MOVEFILE_REPLACE_EXISTING + MOVEFILE_COPY_ALLOWED) If lngTemp <> 0 Then File_Copy = FileExists(NewFileName) Else File_Copy = False End IfEnd Function'=====================================================================' 将文件 strSource 移动到 strDesctation ,并判断文件是否移动成功'=====================================================================Public Function File_Move(strExistingFileName As String, NewFileName As String) As Boolean 'On Error Resume Next Dim lngTemp As Long lngTemp = MoveFileEx(strExistingFileName, NewFileName, MOVEFILE_REPLACE_EXISTING + MOVEFILE_COPY_ALLOWED) If lngTemp <> 0 Then File_Move = FileExists(NewFileName) Else File_Move = False End IfEnd Function'=====================================================================' 遍历 P_From_Path(源文件夹)内的 P_FileName(文件名) 的每一行数据,' 并且TravelFileLineProcess处理得到的每一行的数据'=====================================================================Public Sub TravelFile() 'on error resume next Dim intFileNum As Integer Dim strCurrentLine As String Dim strTemp As String Dim arrayTemp() As String Dim intTemp As Integer strTemp = HouZi_From_Path If Right(strTemp, 1) <> "/" Then strTemp = strTemp + "/" If FileExists(strTemp + HouZi_FileName) = False Then '文件已经不存在 Exit Sub End If intFileNum = FreeFile Open strTemp + HouZi_FileName For Binary As #intFileNum strTemp = Space(LOF(intFileNum)) Get intFileNum, , strTemp Close #intFileNum arrayTemp = Split(strTemp, vbCrLf) If Not IsArrayEmpty(arrayTemp) Then For intTemp = 0 To UBound(arrayTemp) RaiseEvent TravelFileLineProcess(arrayTemp(intTemp), intTemp + 1) Next End If End Sub'=====================================================================' 遍历 P_From_Path(源文件夹)内的每一个文件' 并用 TravelFolderFileProcess 事件来处理'=====================================================================Public Sub TravelFolder() 'on error resume next Dim lHandle As Long 'FindFirstFileA 的句柄 Dim tFindData As WIN32_FIND_DATA ' Dim strFileName As String '文件名 Dim Flag As Long Dim str_Temp As String str_Temp = HouZi_From_Path If Right(str_Temp, 1) <> "/" Then str_Temp = str_Temp + "/" lHandle = FindFirstFile(HouZi_From_Path & "*.*", tFindData) If lHandle = 0 Then '查询结束或发生错误 Exit Sub End If If tFindData.dwFileAttributes >= &H10 And tFindData.dwFileAttributes < &H20 Then '目录 '目录不处理 Else '要处理第一个哦 strFileName = fDelInvaildChr(tFindData.cFileName) If ValidateString(HouZi_RegEx_String, strFileName) Then RaiseEvent TravelFolderFileProcess(strFileName) End If End If '处理 Flag = 1 Do While Flag tFindData.cFileName = "" Flag = FindNextFile(lHandle, tFindData) If tFindData.dwFileAttributes >= &H10 And tFindData.dwFileAttributes < &H20 Then '目录不处理 Else strFileName = fDelInvaildChr(tFindData.cFileName) If ValidateString(HouZi_RegEx_String, strFileName) Then RaiseEvent TravelFolderFileProcess(strFileName) End If End If Loop FindClose (lHandle)End Sub'=====================================================================' 将 strContent 的内容写入到 strfilename 注意:写入后自动追加 vbcrlf'=====================================================================Public Function File_Append(strFileName As String, strContent As String, Optional CrlfFlag As Boolean = True) On Error Resume Next '记着加上取文件名的路径合法性校验,及可写操作.另外程序写完后不换行，一定要注意 Dim intFileNum As Integer Dim strTemp As String intFileNum = FreeFile Open strFileName For Append As #intFileNum If CrlfFlag Then Print #intFileNum, strContent Else Print #intFileNum, strContent; End If Close #intFileNumEnd FunctionPublic Sub Write_Log(LogFile As String, Optional Error_ID As String = "", Optional Error_Description As String = "", Optional Sql_Temp As String = "", Optional File_Name As String = "", Optional Txt_Line As String = "", Optional Op As String = "") Dim Err_Str As String Err_Str = "" If Op <> "" Then Err_Str = Err_Str + "Opreating:" + Op + vbCrLf If Error_ID <> "" Then Err_Str = Err_Str + vbTab + "Error_ID:" + Error_ID + vbCrLf End If If Error_Description <> "" Then Err_Str = Err_Str + vbTab + "Error_Description:" + Error_Description + vbCrLf End If If Sql_Temp <> "" Then Err_Str = Err_Str + vbTab + "Sql:" + Sql_Temp + vbCrLf End If If File_Name <> "" Then Err_Str = Err_Str + vbTab + "File_Name:" + File_Name + vbCrLf End If If Txt_Line <> "" Then Err_Str = Err_Str + vbTab + "Txt_Line:" + CStr(Txt_Line) + vbCrLf End If Call File_Append(LogFile, Convert_Time(, ":") + "," + Err_Str, False) Else Call File_Append(LogFile, Convert_Time(, ":") + "," + Error_ID + "," + Error_Description) End IfEnd SubPublic Function M2U_DATE(M_DATE As String) As String On Error Resume Next '将 "06-JUN-2006 01:01:01" 日期格式转换为 "2006-06-30 01:01:01" Dim Temp As String Dim M_YEAR As String, M_MONTH As String, M_DAY As String Temp = "JAN.FEB.MAR.APR.MAY.JUN.JUL.AUG.SEP.OCT.NOV.DEC." M_DATE = "" + M_DATE If Len(M_DATE) = 20 And IsNumeric(Mid(M_DATE, 8, 4)) And InStr(Temp, UCase(Mid(M_DATE, 4, 3))) And IsNumeric(Left(M_DATE, 2)) And IsDate(Right(M_DATE, 9)) Then M2U_DATE = Mid(M_DATE, 8, 4) + "-" + Right("00" + CStr((InStr(Temp, UCase(Mid(M_DATE, 4, 3))) - 1) / 4 + 1), 2) + "-" + Left(M_DATE, 2) + Right(M_DATE, 9) Else M2U_DATE = "Error" End IfEnd FunctionPublic Function U2M_DATE(U_DATE As String) As String On Error Resume Next '将 "20060101010101" 日期格式转换为 "2006-06-30 01:01:01" U2M_DATE = Mid(U_DATE, 1, 4) + "-" + Mid(U_DATE, 5, 2) + "-" + Mid(U_DATE, 7, 2) + " " + Mid(U_DATE, 9, 2) + ":" + Mid(U_DATE, 11, 2) + ":" + Mid(U_DATE, 13, 2)End Function
