|
![](https://clubstatic.excelhome.net/image/common/ico_lz.png)
楼主 |
发表于 2025-1-25 23:56
|
显示全部楼层
学习学习,再学习。
- <font _mstmutation="1">Function SeparateInfoWithRegex(InputString, Rng As Range)
- Dim RegEx As New VBScript_RegExp_55.RegExp
- Dim Matches As VBScript_RegExp_55.MatchCollection
- Dim Match As VBScript_RegExp_55.Match
- Dim Time As String, Location As String, Weather As String
- Dim Summary As String, PhotoDescription As String
- Set RegEx = New VBScript_RegExp_55.RegExp
- Dim ResultDict As Scripting.Dictionary
- Set ResultDict = New Scripting.Dictionary
- Dim key As Variant
- ' 定义正则表达式
- 'RegEx.Pattern = "时间:(.*?)\n地点:(.*?)\n天气:(.*?)\n路段:.*?\n概述:(.*?)\n照片描述:(.*?)$"
- RegEx.Pattern = "^(时间|天气|地点|概述|照片描述):(.+?)(?=^时间|^天气|^地点|^概述|^照片描述|$)"
-
- With RegEx
- .Global = True
- .MultiLine = True
- .IgnoreCase = True
-
- ' 定义一个通用的模式来匹配所有字段
- .Pattern = "^(时间|天气|地点|道路|概述|照片描述):(.+?)(?=^时间|^天气|^地点|^道路|^概述|^照片描述|$)"
-
- If .Test(InputString) Then
- Set Matches = .Execute(InputString)
-
- For Each Match In Matches
- key = Trim(Match.SubMatches(0))
- ResultDict(key) = Match.SubMatches(1)
- Next Match
- End If
- For jj = 0 To ResultDict.Count - 1
- Rng(, jj + 1) = ResultDict.Items(jj)
- Next jj
-
- End With
- End Function
- '''
- Sub PptNotePageToRng()
- Dim Sht As Worksheet, Rng As Range
- Set Sht = Sheet3
- With Sht
- .Cells.Clear
- .Cells.Font.Size = 9
- Set Rng = .Cells(5, 3)
- End With
-
- Dim Kk As Integer
- Kk = 1
- Dim Pres As PowerPoint.Presentation
- Dim Shp As Shape, Shps As Shapes
-
- Set Pres = RetuPpt
- Dim Sld As Slide, Slds As Slides
- Set Slds = Pres.Slides
- For Each Sld In Slds
- Sld.Name = "Sld" & Kk
- With Sld.NotesPage
- Debug.Print Sld.Name, .Shapes.Count
- For ii = 1 To .Shapes.Count
- If InStr(.Shapes(ii).Name, "备注") > 0 Then
- 'Debug.Print .Shapes(ii).TextFrame.TextRange.Text
- SeparateInfoWithRegex .Shapes(ii).TextFrame.TextRange.Text, Sht.Cells(Kk + 4, 3)
- End If
- Next ii
- End With
- Kk = Kk + 1
- Next Sld
- With Sht
- .Activate
- .Cells.Font.Size = 9
- .Range("C:J").Select
- Selection.ColumnWidth = 50
- .Range("A:J").EntireColumn.AutoFit
- .Range("A:A,C:C").Select
- 'Application.CutCopyMode = False
- Selection.NumberFormatLocal = "G/通用格式"
- Selection.NumberFormatLocal = "yyyy/mm/dd hh:mm:ss"
- End With
- End Sub
- Function RetuPpt() As PowerPoint.Presentation
-
- Dim Dict As New Scripting.Dictionary
- Set Dict = New Scripting.Dictionary
- Dim Ppt As PowerPoint.Application, Shp, Slds 'As Slides
- Dim Pres As Presentation
- Set Ppt = New PowerPoint.Application
- Ppt.Visible = msoTrue
- '''
- For Each Pres In Ppt.Presentations
- Set Dict(Pres.Name) = Pres
- Next Pres
- Set RetuPpt = Dict.Items(0)
- End Function
- '''
- Function OpenPpt(Fso As FileSystemObject, PptName) As Presentation
-
-
- Dim Ppt As PowerPoint.Application, Shp, Slds 'As Slides
- Dim Pres As Presentation
- Set Ppt = New PowerPoint.Application
- Ppt.Visible = msoTrue
- If Fso.FileExists(PptName) = False Then
- Set Pres = Ppt.Presentations.Add
- Pres.Application.Visible = msoTrue
- 'Pres.SaveAs PptName
- Set OpenPpt = Pres
- Exit Function
- End If
-
-
- For Each Pres In Ppt.Presentations
- If Pres.FullName = PptName Then
- Set OpenPpt = Pres
- Exit Function
- End If
- Next Pres
- Set OpenPpt = Ppt.Presentations.Open(PptName, msoFalse)
- Debug.Print OpenPpt.Name, OpenPpt.Path
- Set OpenPpt = Pres
- End Function
- Function JpgDateToDict(oFiles As Files, Dict As Scripting.Dictionary) As Scripting.Dictionary
- Dim oFile As File
- Kk = 1
- For Each oFile In oFiles
- With oFile
- '''
- If InStr(UCase(.Type), "JP") > 0 Then
- Set Dict(oFile.DateLastModified) = oFile
- End If
- End With
- Next oFile
- Set JpgDateToDict = Dict
- End Function
- ''
- Function JpgFilesToDict(oFiles As Files, Dict As Scripting.Dictionary) As Scripting.Dictionary
- Dim oFile As File
- Kk = 1
- For Each oFile In oFiles
- With oFile
- '''
- If InStr(UCase(.Type), "JP") > 0 Then
- Set Dict(oFile.Path) = oFile
- End If
- End With
- Next oFile
- Set JpgFilesToDict = Dict
- End Function
- '''
- Sub JpgDateDictToArr()
- Dim oRow
- oRow = 8
- Dim Sht As Worksheet
- Set Sht = Sheets("FileDate")
- With Sht
- .Activate
- .Cells.Clear
- .Cells.Font.Size = 9
- End With
-
- Dim Rng As Range, Arr
- Dim PicRng As Range
- Set PicRng = Sheets("PicDate").Cells(10, 2).CurrentRegion
- PicRng(, 1).Resize(, 5).Copy
- Sht.Cells(oRow, 3).PasteSpecial xlPasteAll
- '''
- Dim Dict As Scripting.Dictionary, FileDict As Scripting.Dictionary
- Set Dict = New Scripting.Dictionary
- Set FileDict = New Scripting.Dictionary
- Dim Fso As Scripting.FileSystemObject, oFile As File
- Set Fso = New Scripting.FileSystemObject
- Dim oFolder As Folder
- Dim Fia As FileDialog
- Dim Files As Files
- Set oFolder = Fso.GetFolder(ThisWorkbook.Path)
- Set FileDict = JpgDateToDict(oFolder.Files, FileDict)
- oRow = oRow + 1
- For ii = 2 To PicRng.Rows.Count
- 'Debug.Print Dict.Keys(ii), Dict.Items(ii).Name
- Set Dict = DictDateCopyPaste(Dict, FileDict, PicRng(ii, 1))
- Next ii
-
- For ii = 0 To Dict.Count - 1
- Arr = Dict.Items(ii)
- Set oFile = Arr(0)
- Set Rng = Arr(1)
- Rng(, 1).Resize(, 8).Copy
-
- With Sht
- .Cells(oRow + ii, 1) = oFile.Name
- .Cells(oRow + ii, 2) = oFile.DateLastModified
- .Cells(oRow + ii, 3).PasteSpecial xlPasteAll
- .Cells.Font.Size = 9
- End With
- Next ii
- Dim Pres As Presentation
- Set Pres = OpenPpt(Fso, Filename)
- FileDictToPpt Pres, Dict
- End Sub
- ''
- ''</font>
复制代码 |
|