VBA代码个人云笔记2

三、FileSystemObjec备忘
'======找出指定文件夹中最后创建的文件=====================================
Sub Get_Last_Time_Created_File_Fullname()
Dim FSO As Object, sPath As String, fName As String, f0 As String, d0 As String, F As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'sPath = SelectFolder & "\"
sPath = ThisWorkbook.Path & "\"
fName = Dir(sPath & "*.*")
f0 = ""
d0 = #1/1/1900#
Do While fName <> ""
Set F = FSO.Getfile(sPath & fName)
If F.DateCreated > d0 Then d0 = F.DateCreated: f0 = fName
fName = Dir
Loop
MsgBox sPath & f0
End Sub
Function SelectFolder()
Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then sPath = .SelectedItems(1)
End With
SelectFolder = sPath
End Function
'========File and Fold Option=================================
'---Name --------------
Sub Cut_Paste_File()
Dim sOldFull As String, sNewFull As String
sOldFull = ""
sNewFull = ""
Name sOldFull As sNewFull
End Sub
'-----------Create fold---------
Sub CreateFold()
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.Filesystemobject")
oFSO.createfolder ("C:\Users\A8-5600K\Desktop\FWP\Wynn\Clipboard2Excel\Temp2")
End Sub
'------------------------------

四、文本文件
'===将Excel单元格区域内容写入生成的.csv(或.txt)文件=====================
Sub ExcelToCSV(sFullName As String, rArea As Range)
Dim iOutputFileNum As Integer
Dim iRowNum As Integer, iColNum As Integer
Dim ArrLine() As Variant
ReDim ArrLine(1 To rArea.Columns.Count)
iOutputFileNum = FreeFile
Open sFullName For Output As #iOutputFileNum
For iRowNum = 1 To rArea.Rows.Count
For iColNum = 1 To rArea.Columns.Count
ArrLine(iColNum) = rArea(iRowNum, iColNum)
Next iColNum
Print #iOutputFileNum, Join(ArrLine, "'")
Next iRowNum
Close #iOutputFileNum
End Sub
Sub Try_ExcelToCSV()
Call ExcelToCSV(ActiveWorkbook.Path & "\demo_output.txt", ActiveSheet.Range("A1:C6"))
End Sub
'=================================================================
'读写TXT文件的一些方法-----------------------------------
'!!!!!!!!读取TXT文件内容!!!!!!!!!!
Sub ReadTxt()
Dim sFullName: sFullName = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt), *.txt")
Open sFullName For Input As #1
MsgBox StrConv(InputB(LOF(1), 1), vbUnicode)
Close #1
End Sub
'+++生成并写入TXT文件+++++++++++++++++
Sub WriteTXT()
Open ActiveWorkbook.Path & "\demo_output.txt" For Output As #2
Print #2, "Row1"
Print #2, "Row2"
Print #2, "Row3"
Print #2, "Row4"
Close #2
End Sub
'/// 附加方式寫入TXT文件//////////////////////
Sub TXT_Append()
Dim FileName As String
FileName = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt), *.txt")
Open FileName For Append As #3
Print #3, "This is another test."
Close #3
End Sub
'%%%%%%%%以数组形式取得TXT文件内容,以行为单位%%%%%%%%%%%%%%%%%%%%%%%%
Function TxtToArray(FullName As String)
Open FullName For Input As #1
TxtToArray = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
Close #1
End Function
Sub Try_TxtToArray()
Dim arrA As Variant, iA As Integer
Dim sFullName As String
sFullName = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt), *.txt")
arrA = TxtToArray(sFullName)
For iA = 0 To UBound(arrA) - 1
MsgBox arrA(iA)
Next
End Sub
'本示例使用 FreeFile 函数来返回下一个可用的文件号。在循环中，共打开五个输出文件，并在每个文件中写入一些数据。
Sub CreateMulitFile()
Dim MyIndex, FileNumber
For MyIndex = 1 To 5 ' 循环五次。
FileNumber = FreeFile ' 取得未使用的文件号。
Open "TEST" & MyIndex For Output As #FileNumber ' 创建文件名。
Write #FileNumber, "This is a sample." ' 输出文本至文件中。
Close #FileNumber ' 关闭文件。
Next MyIndex
End Sub
'Open...For...有3种方法 1,Input代表读取TXT文件 2,Output代表（生成并）写入TXT文件 3,APPend代表把内容添加到TXT文件后面
'文件号前需加#,自动获取可用文件号的函数是 FreeFile

二、插入图片（改）
'===工作表中有很多合并单元格需要插入图片并居中，先删除表中全部图片（ActiveX除外），按格式查找合并单元格区域,如长宽都大于5个单元格，
'===用“一、递归”找到 开头几个字母 与 合并单元格内字符 相同的图片文件的全路径，在合并单元格内插入图片并居中===
Sub MergeCells_Insert_Picture()
Dim rArea As Range
Set rArea = Range("A1:AB50")
Call DeleteAllShape(rArea)
Dim sFirstAddress As String, rMerge As Range
Application.FindFormat.Clear
Application.FindFormat.MergeCells = True 'Set search format
With rArea
Set rMerge = .Find(what:="", LookIn:=xlFormulas, lookat:=xlPart, searchformat:=True) 'Search by Format
If rMerge Is Nothing Then MsgBox "Havn't Merge cell!": Exit Sub
sFirstAddress = rMerge.Address
Do
If rMerge.MergeArea.Rows.Count > 5 And rMerge.MergeArea.Columns.Count > 5 Then
Call InsertPicture(rMerge, ActiveWorkbook.Path & "\")
End If
Set rMerge = .Find(what:="", after:=rMerge, searchformat:=True) 'Search next
Loop While sFirstAddress <> rMerge.Address
End With
End Sub
Sub InsertPicture(rCell As Range, Optional sSelPath, Optional sFileNameKeyword) 'optional只对Variant有效，对其他格式无效
'---Input or Select Path-----
Dim sPath As String
If IsMissing(sSelPath) Then
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then sPath = .SelectedItems(1)
End With
If sPath = "False" Or Len(sPath) = 0 Then Exit Sub
Else
sPath = sSelPath
End If
'-----Get file full name-------------
Dim sFullName As String, sFileKeyword As String, sA As String
If IsMissing(sFileNameKeyword) Then
sFileKeyword = rCell.Cells(1).Value
Else
sFileKeyword = sFileNameKeyword
End If
sFullName = GetRecurFile(sPath, sFileKeyword)
If Len(sFullName) < 5 Then Exit Sub
sA = UCase(Right(sFullName, 4))
If sA <> ".BMP" And sA <> ".PNG" And sA <> ".GIF" And sA <> "JPEG" And sA <> "TIFF" Then
Exit Sub
End If
'---Insert Picture form file to Merging-cell--------
Dim rM As Range
Set rM = rCell.Cells(1).MergeArea
ActiveSheet.Shapes.AddPicture sFullName, True, True, rM.Left + 10, rM.Top + 10, rM.Width - 20, rM.Height - 20
End Sub
Sub DeleteAllShape(rArea As Range) 'Delete All Shape except DirectX
Dim spA As Shape
For Each spA In ActiveSheet.Shapes
If Not Application.Intersect(spA.TopLeftCell, rArea) Is Nothing Then
If spA.Type <> 8 Then spA.Delete '8 is ActiveX
End If
Next spA
End Sub

五、获取文件列表 数组
Option Explicit
Option Compare Text
'===获取选中文件夹中全部文件（或文件夹）的完整路径,包括子文件夹（中的文件）返回变量数组===============
'===利用双层Do循环,把各个子文件夹添加到vKeys一维组数.
'===在第二层DO循环里,不管哪一层子文件夹都顺序添加到字典dicA. 下一次在第一层Do循环把字典重新赋给数组vKeys
'===如C:\AA1\BB2 ，之前vKeys(iA)中iA最大为3. 在AA1文件夹下找到,BB1,BB2,BB3三个子文件夹。vKeys(4)=BB1,vKeys(5)=BB2,vKeys(6)=BB3(均为完整路径）
'===数组在第二层Do循环可能增加多个值,相当于列出长长的清单。但iA每循环一次只增加1. 相当于指针每个循环往下一格。
'===dicA.Count 因此增加,iA=iA+1,在第一层Do循环按iA顺序读取vKeys(iA),直到iA>dicA.count
'参数1：sPath 必须 字符串 指定文件夹完整路劲
'参数2：sFileType 可选 字符串 指定文件名或后序名 默认选中全部类型文件
'参数3：bFoldersOnly 可选 布朗值 指定返回文件夹列表 默认返回文件列表
'参数4：sExceptFolds 可选 字符串 指定要排除的文件夹,可多选,用分号隔开, '如"*QQ*:*WeChat*"排除带QQ或WeChat字样的文件夹
'参数5：sIncludeFolds 可选 字符串 指定要包含的文件夹,可多选,用分号隔开,'如"*QQ*:*WeChat*"只返回带QQ或WeChat字样的文件夹
'参数6：DoLimit 可选 数字型 指定遍历文件上限 默认为5000,文件数超过限制则结束遍历
Function TraversalFile(sPath As String, Optional sFileType = "*.*", Optional bFoldersOnly = False, Optional sExceptFolds, Optional sIncludeFolds, Optional DoLimit = 5000) '返回Variant()数组
Dim sName As String
Dim dicA, dicFold, dicFile, vKeys, vExceptFold, vIncludeFold As Variant
Dim iA As Integer, iB As Integer, iC As Integer, iD As Integer, iE As Integer
If sPath = "" Then End
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
If Not IsMissing(sExceptFolds) Then vExceptFold = Split(sExceptFolds, ":")
If Not IsMissing(sIncludeFolds) Then vIncludeFold = Split(sIncludeFolds, ":")
Set dicA = CreateObject("Scripting.Dictionary")
Set dicFold = CreateObject("Scripting.Dictionary")
Set dicFile = CreateObject("Scripting.Dictionary")
dicA.Add sPath, ""
iA = 0
Do While iA < dicA.Count And iA < DoLimit
vKeys = dicA.keys '子文件夹列表数组,每找到一个子文件夹就加到这个数组,类似递归
sName = Dir(vKeys(iA), vbDirectory)
Do While sName <> "" And iB < DoLimit
If sName <> "." And sName <> ".." Then
'++++++++++排除指定文件夹+++
iD = 0
If Not IsMissing(sExceptFolds) Then
For iC = 0 To UBound(vExceptFold)
If vKeys(iA) Like "*\" & vExceptFold(iC) & "\*" Then iD = iD + 1
Next
End If
'++++++++++++++++++++++++++++
'---------只选择指定文件夹---
iE = 1
If Not IsMissing(sIncludeFolds) Then
iE = 0
For iC = 0 To UBound(vIncludeFold)
If vKeys(iA) Like "*\" & vIncludeFold(iC) & "\*" Then iE = iE + 1
Next
End If
'----------------------------
On Error Resume Next
'>>>>>>核心部分,如果是子文件夹,则添加到上一层Do循环的vKeys数组>>>>>>>>
If (GetAttr(vKeys(iA) & sName) And vbDirectory) = vbDirectory Then 'vbDirectory=16,代表文件夹
If Err <> 0 Then MsgBox Err.Description & vbCr & vKeys(iA) & sName: Set dicA = Nothing: Set dicFold = Nothing: Set dicFile = Nothing: End
dicA.Add vKeys(iA) & sName & "\", "" '子文件夹列表,每找到一个子文件夹就加到这个字典
If iD = 0 And iE > 0 Then dicFold.Add vKeys(iA) & sName, "" '选中的文件夹写入字典
Else '>>>如果不是文件夹,则选中的文件写入字典
If sName Like sFileType Then
If iD = 0 And iE > 0 Then dicFile.Add vKeys(iA) & sName, "" '选中的文件写入字典
End If
End If
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
On Error GoTo 0
End If
sName = Dir
iB = iB + 1: If iB >= DoLimit Then MsgBox "Files quantity more than limit : " & DoLimit
Loop
iA = iA + 1: If iA >= DoLimit Then MsgBox "Foloder quantity more than limit : " & DoLimit
Loop
TraversalFile = IIf(bFoldersOnly, dicFold.keys, dicFile.keys)
Set dicA = Nothing
Set dicFold = Nothing
Set dicFile = Nothing
End Function
Function MySelectFolder()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then MySelectFolder = .SelectedItems(1)
End With
End Function
Sub try_TraversalFile()
Dim a, i
a = TraversalFile(MySelectFolder, "*.*", 0, "*QQ*", "*C:*", 5000)
For i = 0 To UBound(a) - 1
Debug.Print a(i)
Next
End Sub
'简易版本
Function TraversalFile_Simple(sPath As String)
Dim sName, dicA, dicFile, vKeys, iA
Set dicA = CreateObject("Scripting.Dictionary")
Set dicFile = CreateObject("Scripting.Dictionary")
dicA.Add sPath, ""
Do While iA < dicA.Count
vKeys = dicA.keys
sName = Dir(vKeys(iA), vbDirectory)
Do While sName <> ""
If sName <> "." And sName <> ".." Then
If (GetAttr(vKeys(iA) & sName) And vbDirectory) = vbDirectory Then
dicA.Add vKeys(iA) & sName & "\", ""
Else
dicFile.Add vKeys(iA) & sName, ""
End If
End If
sName = Dir
Loop
iA = iA + 1
Loop
TraversalFile_Simple = dicFile.keys
End Function
Sub Try_TraversalFile_Simple()
Dim a, i
a = TraversalFile_Simple(MySelectFolder & "\")
For i = 0 To UBound(a)
Debug.Print a(i)
Next
End Sub

这是个好东西，收藏了，谢谢

Sub AddReference()
Const GUID As String = "{420B2830-E718-11CF-893D-00A0C9054228}" 'Scripting.Runtime的GUID
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromGuid GUID, 1, 0 '1.0版本
If Err.Number = 0 Then
MsgBox "引用添加成功"
Else
MsgBox "引用添加失败: " & Err.Description
End If
End Sub

' 递归处理文件夹
Sub RecursionF(oFold As Object)
Dim oSubF As Object, oFile As Object
For Each oFile In oFold.Files
Debug.Print oFile.Name
Next oFile
' 递归处理子文件夹
For Each oSubF In oFold.SubFolders
Call RecursionF(oSubF)
Next oSubF
End Sub
‘Set oFSO = CreateObject("scripting.Filesystemobject")’

好代码，值得收藏！