工作中自己编写的VBA工具，为了记录用（文件处理，PPT，EXCEL，转CSV，合并单元格，时间函数）

'Two useful Functions:

'Use Function below for reference       To judge whether the folder path is exist
Public Function FileFolderExists(strFullPath As String) As Boolean

FileFolderExists = False
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then
FileFolderExists = True
EarlyExit:
On Error GoTo 0
End If
End Function

'Author: hiperion
'Resource: CSDN
'Original Article: https://blog.csdn.net/ocean20/article/details/6411316

'Open Windows ChooseFolder form application
Public Function ChooseFolder() As String

Dim dlgOpen As FileDialog 'this type FileDialog is microsoft object

Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)

With dlgOpen
If .Show = -1 Then
ChooseFolder = .SelectedItems(1)
End If
End With
Set dlgOpen = Nothing
End Function

'Get Control of PPT file
Dim fso, folder, fds, fd, folder2, fs, f, pptapp
Dim PPTobj As Object
        
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder1 = fso.GetFolder(XXXX)  'getFolder XXX is its path
    Set fds = folder1.subfolders        'collection of sub folder
    Set pptapp = CreateObject("powerpoint.application")  
'define Object to PPT application
    For Each fd In fds                  'travesals every subfolder
        Set folder2 = fd                
        Set fs = folder2.Files          
        For Each f In fs                'travesals every file in subfolder
        
If f.Name Like "*.pptx" Then
Set PPTobj = GetObject(f.path)    
'f type is file, cannot get attributes of PPT, so need to define an Object to set as f(PPT)
        Set pptapp = PPTobj       
'pptapp type is PPT application, get PPTobj(f)
        Debug.Print pptapp.Slides.Count  'Finally can use PPT’s attributes [Slides.Count]
        FileCopy f.path, TarAddress & "\" & f.Name    
'FileCopy [file.path], [targetAddress&file.Name]
End If
        Next







'Get Control of Excel & Windows Files
Dim fso, folder1, f As Object
Dim fexcel As Workbook
Dim fTitle As String

'Set fexcel = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")     
' To give fso object a filesystemobject script function  [very important]
On Error Resume Next
   Application.DisplayAlerts = False

If FileFolderExists(FileFoderPath) Then
        Set folder1 = fso.GetFolder(FileFoderPath)  'GetFolder
End If

If folder1.Files.Count = 0 Then
Else
   For Each f In folder1.Files
   	'FileCopy f.path, TarAddress & "\" & f.Name
Set fexcel = GetObject(f.path)     'get file object to workbook
Debug.Print fexcel.Sheets.Count
fexcel.Close SaveChanges:=False
        Set fecxel = Nothing
   Next
End If
Application.DisplayAlerts = True

Sub TurnToCSV()

Dim wS As Worksheet
Dim sPath As String

On Error Resume Next
sPath = ChooseFolder()    'Open Folder path
If sPath = "" Then
Exit Sub
End If

'Debug.Print sPath

For Each wS In ThisWorkbook.Sheets
                'wS.SaveAs sPath & "\" & wS.Name & ".csv", xlCSV, CreateBackup:=False, TextCodePage:=utf - 8
                'wS.SaveAs sPath & "\" & wS.Name & ".csv", xlUnicodeText, CreateBackup:=False, TextCodePage:=utf - 8
Next wS
End Sub

Public Function ChooseFolder() As String

Dim dlgOpen As FileDialog

Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
If .Show = -1 Then
ChooseFolder = .SelectedItems(1)
End If
End With
Set dlgOpen = Nothing
End Function

Sub MergeCells()

Dim x, y As Integer

'Call delay(5) 'Time delay function  5second

x = Selection.Row   'x is the row which you choose
y = Selection(1).Column    'y is the first column which you choose

'Debug.Print x & " " & y

Range(x & ":" & x).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove  'this command add one row above your chosen row

For i = 1 To y - 1
Range(Cells(x - 1, i), Cells(x, i)).Merge    'Merge cells
Next

End Sub

Sub delay(T As Single)
    Dim time1 As Single
    time1 = Timer   'Timer is now time in System
    Do
        DoEvents        'This sentance means transfer control right to computer to do another program
    Loop While Timer - time1 < T
End Sub