文档库

最新最全的文档下载
当前位置:文档库 > 转PDF宏

转PDF宏

Sub AutoOpen()
KeyBindings.add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="盐田PDF"
KeyBindings.add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="批量转PDF"
End Sub
Sub 宝安PDF()
Dim str As String, Nam As String, t As Variant
str = http://www.wendangku.net/doc/f3046949767f5acfa1c7cd1f.html
t = ActiveDocument.path
Nam = CreateObject("Scripting.FileSystemObject").getextensionname(str)
ActiveDocument.ExportAsFixedFormat OutputFileName:=("\\Server\多功能检测车数据\7-市政最终版报告\PDF报告\1-宝安区报告汇总(20120920最终版)\" & Replace(str, Nam, "pdf")), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True
ActiveDocument.Save
ActiveDocument.Close '退出文档
End Sub

Sub 南山PDF()
Dim str As String, Nam As String, t As Variant
str = http://www.wendangku.net/doc/f3046949767f5acfa1c7cd1f.html
t = ActiveDocument.path
Nam = CreateObject("Scripting.FileSystemObject").getextensionname(str)
ActiveDocument.ExportAsFixedFormat OutputFileName:=("\\Server\多功能检测车数据\7-市政最终版报告\PDF报告\3-南山区报告汇总(20120920最终版)\" & Replace(str, Nam, "pdf")), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True
ActiveDocument.Save
ActiveDocument.Close '退出文档
End Sub

Sub 罗湖PDF()
Dim str As String, Nam As String, t As Variant
str = http://www.wendangku.net/doc/f3046949767f5acfa1c7cd1f.html
t = ActiveDocument.path
Nam = CreateObject("Scripting.FileSystemObject").getextensionname(str)
ActiveDocument.ExportAsFixedFormat OutputFileName:=("\\Server\多功能检测车数据\7-市政最终版报告\PDF报告\4-罗湖区报告汇总(20120920最终版)\" & Replace(str, Nam, "pdf")), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _

Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True
ActiveDocument.Save
ActiveDocument.Close '退出文档
End Sub

Sub 盐田PDF()
Dim str As String, Nam As String, t As Variant
str = http://www.wendangku.net/doc/f3046949767f5acfa1c7cd1f.html
t = ActiveDocument.path
Nam = CreateObject("Scripting.FileSystemObject").getextensionname(str)
ActiveDocument.ExportAsFixedFormat OutputFileName:=("\\Server\多功能检测车数据\7-市政最终版报告\PDF报告\5-盐田区报告汇总(20120920最终版)\" & Replace(str, Nam, "pdf")), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True
ActiveDocument.Save
ActiveDocument.Close '退出文档
End Sub

Sub 批量转PDF()
Dim i As Variant
Dim t As Variant
Dim str As String, n As Long, fd, Nam As String
On Error GoTo err
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "选择目标文件夹"
If .Show = -1 Then t = .SelectedItems(1) Else Exit Sub
End With
str = Dir(t & "\*.doc*")
While Len(str) > 0
n = n + 1
Documents.Open FileName:=t & IIf(Right(t, 1) = "\", "", "\") & str
Nam = CreateObject("Scripting.FileSystemObject").getextensionname(str)
ActiveDocument.ExportAsFixedFormat OutputFileName:=(t & IIf(Right(t, 1) = "\", "", "\") & Replace(str, Nam, "pdf")), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True
ActiveDocument.Close False
str = Dir()
Wend
Set fd = Nothing
MsgBox ("已完成全部转换")
err:
End Sub