自用的一个vb类

最新推荐文章于 2024-03-10 15:50:52 发布

pzhan

最新推荐文章于 2024-03-10 15:50:52 发布

阅读量1.5k

点赞数

文章标签： vb string function date path integer

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "HouZi"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option 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 = 260
Private Const OFS_MAXPATHNAME = 128
Private Const OF_EXIST = &H4000
Private Const MOVEFILE_REPLACE_EXISTING = &H1
Private Const MOVEFILE_COPY_ALLOWED = &H2

Private Type FILETIME
    dwLowDateTime   As Long
    dwHighDateTime As Long
End Type

Private 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

Private Type OFSTRUCT
        cBytes As Byte
        fFixedDisk As Byte
        nErrCode As Integer
        Reserved1 As Integer
        Reserved2 As Integer
        szPathName(OFS_MAXPATHNAME) As Byte
End Type

Private Declare Function apiOpenFile Lib "kernel32" Alias "OpenFile" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private 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 Long
Private 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 Long
Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long

Public Event TravelFolderFileProcess(strFileName As String)
Public Event TravelFileLineProcess(strCurrentLine As String, lngCurrentLineNo As Long)

Private HouZi_From_Path     As String
Private HouZi_To_Path       As String
Private HouZi_RegEx_String As String
Private HouZi_Tag           As String
Private HouZi_FileName      As String
Private Houzi_LogFile       As String
Private 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_State
End Property
Public Property Let P_State(strState As String)
    If strState <> "" Then
         Houzi_State = strState
    End If
End Property

'=====================================================================
' 操作记录的文件路径(注：要求绝对路径)
'=====================================================================
Public Property Get P_LogFile() As String
    P_LogFile = Houzi_LogFile
End Property
Public Property Let P_LogFile(Absolute_Path As String)
    If Absolute_Path <> "" Then
         Houzi_LogFile = Absolute_Path
    End If
End Property

'=====================================================================
' 正则表达式匹配方式属性处理
'=====================================================================
Public Property Get RegEx_String() As String
    RegEx_String = HouZi_RegEx_String
End Property
Public Property Let RegEx_String(strPatternIn As String)
    If strPatternIn <> "" Then
         HouZi_RegEx_String = strPatternIn
    End If
End Property

'=====================================================================
' 源文件夹属性处理
'=====================================================================
Public Property Get P_From_Path() As String
    P_From_Path = HouZi_From_Path
End Property
Public Property Let P_From_Path(strFromFolder As String)
    If strFromFolder <> "" Then
         HouZi_From_Path = strFromFolder
    End If
End Property

'=====================================================================
' 目标文件夹属性处理
'=====================================================================
Public Property Get P_To_Path() As String
    P_To_Path = HouZi_To_Path
End Property
Public Property Let P_To_Path(strToFolder As String)
    If strToFolder <> "" Then
         HouZi_To_Path = strToFolder
    End If
End Property

'=====================================================================
' 备注属性处理
'=====================================================================
Public Property Get Tag() As String
    Tag = HouZi_Tag
End Property
Public Property Let Tag(strTemp As String)
    If strTemp <> "" Then
         HouZi_Tag = strTemp
    End If
End Property

'=====================================================================
' 文件名属性处理
'=====================================================================
Public Property Get P_FileName() As String
    P_FileName = HouZi_FileName
End Property
Public Property Let P_FileName(Only_FileName As String)
    If Only_FileName <> "" Then
         HouZi_FileName = Only_FileName
    End If
End 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
    Next
End 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 = Nothing
End 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 If
End 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 #intFileNum
End 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 #intFileNum
End 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 If
End 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 If
End 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 = 0
End 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 If
End 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 If
End 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 #intFileNum
End Function
Public 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 If

End Sub

Public 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 If
End Function
Public 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