记录1

dl0506

1. Public Function GetValueByKey(strKey As String, iOffsetValue As Long) As String
   
2.     Dim mySheet As Worksheet
   
3.     Set mySheet = ThisWorkbook.Worksheets("ConfigSheet")
   
4.     GetValueByKey = mySheet.UsedRange.Find(strKey, Lookat:=xlWhole).Offset(0, iOffsetValue).Value
   
5. End Function

复制代码

Public Function GetExcelWorkSheetName(ByVal strFileFullPath As String) As Variant()
    '/ ADOX
'    Dim cat As New ADOX.Catalog
    Dim cat As Object
    Dim myTable As Object
    Dim iLoop As Long
    Dim arr()
    Dim sNewSheetName As String
    Set cat = CreateObject("ADOX.catalog")
    cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & strFileFullPath
    For Each myTable In cat.Tables
        If myTable.Type = "TABLE" Then
            sNewSheetName = VBA.Replace(myTable.Name, "'", "")
            If VBA.right(sNewSheetName, 1) = "$" Then
                iLoop = iLoop + 1
                ReDim Preserve arr(1 To iLoop)
                arr(iLoop) = sNewSheetName
            End If
        End If
    Next
    GetExcelWorkSheetName = arr
    Set cat = Nothing
End Function

1. Public Sub ShowMsgbox(ByVal sMsgContent As String, ByVal iMsgType As Integer)
   
2.     Select Case iMsgType
   
3.         '/ Information
   
4.         Case 1
   
5.             MsgBox sMsgContent, vbInformation + vbOKOnly, "Information"
   
6.         '/ Warning
   
7.         Case 2
   
8.             MsgBox sMsgContent, vbExclamation + vbOKOnly, "Warning"
   
9.     End Select
   
10. End Sub

复制代码

Public Function TimeDiff(dteStart As Date, dteEnd As Date) As String
    Dim lngDiff As Long
    Dim i As Integer
    Dim strCheck(3)
    lngDiff = DateDiff("s", dteStart, dteEnd)
    strCheck(0) = CStr(lngDiff Mod 60) & "s"
    strCheck(1) = CStr(lngDiff \ 60 Mod 60) & "m"
    strCheck(2) = CStr(lngDiff \ 60 \ 60 Mod 24) & "h"
    strCheck(3) = CStr(lngDiff \ 60 \ 60 \ 24) & "d"

    For i = 0 To 3
        If left(strCheck(i), 1) = "0" Then
            strCheck(i) = ""
        End If
    Next
    TimeDiff = strCheck(3) & strCheck(2) & strCheck(1) & strCheck(0)
End Function

1. Public Function GetFileExtenName(ByVal strFileFullPath As String) As String
   
2.     Dim sFileName As String
   
3.     Dim fso As Object
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     sFileName = "." & fso.GetExtensionName(strFileFullPath)
   
6.     If Trim(sFileName) <> "" Then
   
7.         GetFileExtenName = sFileName
   
8.     End If
   
9.     Set fso = Nothing
   
10. End Function
    
11. Public Sub EmptyFolderFiles(ByVal strFolderPath As String)
    
12.     Dim fso As Object
    
13.     Dim EachFile As Object
    
14.     Dim oFolder As Object
    
15.     Set fso = CreateObject("Scripting.FileSystemObject")
    
16.     Set oFolder = fso.GetFolder(strFolderPath)
    
17.     For Each EachFile In oFolder.Files
    
18.         EachFile.Delete
    
19.     Next
    
20.     Set fso = Nothing
    
21.     Set oFolder = Nothing
    
22. End Sub
    
23. Public Function CheckFolderFileEmpty(ByVal strFolderPath As String) As Boolean
    
24.     Dim fso As Object
    
25.     Dim oFolder As Object
    
26.     Dim oFiles As Object
    
27.     Dim oFile As Object
    
28. 'Dim fso As New FileSystemObject
    
29. 'Dim oFolder As Folder
    
30. 'Dim oFile As File
    
31.     CheckFolderFileEmpty = False
    
32.     Set fso = CreateObject("Scripting.FileSystemObject")
    
33.     Set oFolder = fso.GetFolder(strFolderPath & "")
    
34.     If oFolder.Files.Count = 0 Then
    
35.         CheckFolderFileEmpty = True
    
36.     Else
    
37.         For Each oFile In oFolder.Files
    
38.             If VBA.left(fso.GetExtensionName(oFile.Name), 3) <> "xls" Then
    
39.                 Call ShowMsgbox("[ " & oFile.Name & " ] is NOT Excel File Format,Please Check it.", 2)
    
40.                 CheckFolderFileEmpty = True
    
41.                 Exit Function
    
42.             End If
    
43.         Next
    
44.     End If
    
45.     Set fso = Nothing
    
46.     Set oFolder = Nothing
    
47.     Set oFile = Nothing
    
48. End Function

复制代码

Public Function GetFilesName(ByVal FileFolderPath As String)
    Dim objFileSysObj As Object
    Dim objFolder As Object
    Dim objFiles As Object
    Dim objFile As Object
    Dim sFiles() As String
    Dim iCount As Long
    Dim k As Long

    Set objFileSysObj = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFileSysObj.GetFolder(FileFolderPath)
    Set objFiles = objFolder.Files
    iCount = objFiles.Count
    If iCount = 0 Then
        MsgBox " No File Existed in Input Folder."
        Exit Function
    End If

    ReDim sFiles(iCount - 1)
    For Each objFile In objFiles
        If left((objFile.Name), 1) <> "~" Then
            If left(GetFileExtenName(objFile.Name), 4) = ".xls" Then
                sFiles(k) = objFile.Name
                k = k + 1
            End If
        End If
    Next
    GetFilesName = sFiles()
End Function

Public Function CheckFolderPathExists(ByVal strFolderFullPath As String)
    Dim fso As Object
'Dim fso As New FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(strFolderFullPath) = False Then
        fso.CreateFolder (strFolderFullPath)
    End If
End Function