'WORD 加载项 代码模板
Dim cmdBar As CommandBar, cmdBtn As CommandBarControl
Const cmdBtnCap As String = "批量提取操作步骤"Sub AutoExec()Call DelCmdBtnCall AddCmdBtnEnd Sub
Sub AutoExit()Call DelCmdBtn
End SubSub AddCmdBtn()Set cmdBar = Application.CommandBars("Tools")Set cmdBtn = cmdBar.Controls.Add(msoControlButton)With cmdBtn.Caption = cmdBtnCap.Style = msoButtonCaption.OnAction = "GetContents"End WithSet cmdBtn = NothingSet cmdBar = NothingEnd Sub
Sub DelCmdBtn()Set cmdBar = Application.CommandBars("Tools")For Each cmdBtn In cmdBar.ControlsIf cmdBtn.Caption = cmdBtnCap Then cmdBtn.DeleteNextSet cmdBtn = NothingSet cmdBar = Nothing
End SubPublic Sub GetContents()Application.ScreenUpdating = FalseDim xlApp As ObjectDim Wb As ObjectDim Sht As ObjectDim Rng As ObjectDim OpenDoc As DocumentDim ExcelPath As StringConst ExcelFile As String = "未完成.xls"Dim FolderPath As StringDim FilePath As StringDim FileName As StringExcelPath = ThisDocument.Path & "\" & ExcelFileWith Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = ThisDocument.Path.AllowMultiSelect = False.Title = "请选取Word所在文件夹"If .Show = -1 ThenFolderPath = .SelectedItems(1)ElseMsgBox "您没有选中任何文件夹，本次汇总中断！"Exit SubEnd IfEnd Withs = Split(FolderPath, "\")c = UBound(s)ShtName = s(c)If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"On Error Resume NextSet xlApp = GetObject(, "Excel.Application")If xlApp Is Nothing ThenSet xlApp = CreateObject("Excel.Application")End IfOn Error GoTo 0Set Wb = xlApp.workbooks.Open(ExcelPath)Set Sht = Wb.worksheets.Add()Sht.Name = ShtNameSht.Cells.clearcontentsSht.Range("A1:D1").Value = Array("操作编号", "操作任务", "操作序号", "操作步骤")FileName = Dir(FolderPath & "*.doc*")Do While FileName <> ""FilePath = FolderPath & FileNameIf FileName <> ThisDocument.Name ThenSet OpenDoc = Application.Documents.Open(FilePath)'If OpenDoc.Tables.Count > 0 ThenArr = GetArray(OpenDoc)Debug.Print Arr(3, 1)Sht.Cells(Sht.Rows.Count, 2).End(3).offset(1).Resize(UBound(Arr, 2), UBound(Arr)).Value = _xlApp.worksheetfunction.transpose(Arr)'End IfOpenDoc.Close FalseEnd IfFileName = DirLoopWb.Close TruexlApp.Quit'MsgBox "本次提取完成！"'Application.ScreenUpdating = True
End SubFunction GetArray(ByVal Doc As Document) As VariantDim tb As TableDim tbCount As LongDim RecordStart As BooleanDim RecordEnd As BooleanDim Arr() As StringDim Mission As StringDoc.ActivateIf Selection.Type = wdSelectionIP ThenActiveDocument.Content.ListFormat.ConvertNumbersToTextActiveDocument.Content.Find.Execute FindText:="^t", replacewith:=" ", Replace:=wdReplaceAllElseSelection.Range.ListFormat.ConvertNumbersToTextSelection.Find.Execute FindText:="^t", replacewith:=" ", Replace:=wdReplaceAllEnd IfReDim Arr(1 To 3, 1 To 1)Index = 0RecordStart = FalseRecordEnd = FalsetbCount = Doc.Tables.CountIf tbCount > 0 Thenn = 0For Each tb In Doc.TablesWith tbFor i = 1 To .Rows.Count'Debug.Print tb.Rows(3).Cells(1).Range.TextIf tb.Rows(3).Cells(1).Range.Text Like "*操作任务*" And Mission = "" ThenMission = tb.Rows(3).Cells(1).Range.TextMission = RegGet(Mission, "操作任务[：:](\S+?)\s+?")'Debug.Print MissionEnd IfIf .Rows(i).Cells.Count = 5 ThenIf .Rows(i).Cells(1).Range.Text Like "*#*" And _.Rows(i).Cells(3).Range.Text Like "*得令*" Then'Debug.Print .Rows(i).Cells(3).Range.TextRecordStart = TrueEnd IfIf .Rows(i).Cells(1).Range.Text Like "*#*" Or .Rows(i).Cells(1).Range.Text = "" And RecordStart = True And RecordEnd = False ThenIndex = Index + 1ReDim Preserve Arr(1 To 3, 1 To Index)Arr(1, Index) = MissionDebug.Print MissionArr(2, Index) = Replace(Replace(.Rows(i).Cells(1).Range.Text, Chr(7), ""), vbCr, "")Arr(3, Index) = Replace(Replace(.Rows(i).Cells(3).Range.Text, Chr(7), ""), vbCr, "")End IfIf .Rows(i).Cells(1).Range.Text Like "*#*" And _.Rows(i).Cells(3).Range.Text Like "*汇报*" ThenRecordStart = FalseRecordEnd = TrueGoTo ExitFunctionEnd IfEnd IfNext iEnd WithNext tbEnd IfExitFunction:GetArray = ArrEnd Function
Public Function RegGet(ByVal OrgText As String, ByVal Pattern As String) As String
'传递参数 ：原字符串， 匹配模式Dim Regex As ObjectDim Mh As ObjectSet Regex = CreateObject("VBScript.RegExp")With Regex.Global = True.Pattern = PatternEnd WithIf Regex.test(OrgText) ThenSet Mh = Regex.Execute(OrgText)RegGet = Mh.Item(0).submatches(0)ElseRegGet = ""End IfSet Regex = Nothing
End Function
Sub 自动编号转文本()If Selection.Type = wdSelectionIP ThenActiveDocument.Content.ListFormat.ConvertNumbersToTextActiveDocument.Content.Find.Execute FindText:="^t", replacewith:=" ", Replace:=wdReplaceAllElseSelection.Range.ListFormat.ConvertNumbersToTextSelection.Find.Execute FindText:="^t", replacewith:=" ", Replace:=wdReplaceAllEnd If
End Sub