|
刚才发的帖子哪里去了,不得不重发。
Sub AutoOpen()
UserForm1.ComboBox1.List = Array("doc文件", "docx文件", "docm文件")
End Sub
Sub 重命名()
Dim thispath$, myfile$, mydoc As Document, sr$
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveDocument.Path
.Title = "选取待压缩文件位置"
.ButtonName = "选定路径"
If .Show = -1 Then SelPth = .SelectedItems(1)
End With
If Len(SelPth) > 0 Then thispath = SelPth & "\": pth = Left$(SelPth, InStrRev(SelPth, "\") - 1) & "\"
On Error Resume Next
MkDir pth & "命名后文档"
On Error GoTo 0
myfile = Dir(thispath & "*.doc")
Select Case UserForm1.ComboBox1.Text
Case "doc文件"
hzh = ".doc"
typ = wdFormatDocument
Case "docx文件"
hzh = ".docx"
typ = wdFormatXMLDocument
Case Else
hzh = ".docm"
typ = wdFormatXMLDocumentMacroEnabled
End Select
Do While myfile <> ""
If myfile <> ActiveDocument.Name Then
Set mydoc = Documents.Open(thispath & myfile)
sr = mydoc.Tables(1).Cell(2, 3).Range.Text
sr = Replace(Replace(sr, " ", ""), Chr(13) & Chr(7), "")
targetstr = pth & "命名后文档\" & sr & hzh
mydoc.SaveAs2 targetstr, FileFormat:=typ
If UserForm1.CheckBox1.Value = True Then
mydoc.ExportAsFixedFormat OutputFileName:=pth & "命名后文档\" & sr & ".pdf", ExportFormat:=wdExportFormatPDF '转为pdf格式文件
End If
mydoc.Close 0
End If
myfile = Dir
Loop
End Sub
谢谢 leikaiyi123提醒,谢谢小花鹿赐给的源代码
如果你觉得满意的话,请赏朵小花!!
请测试附件。
附件如下:
|
|