Question

我正在尝试创建一个宏来在活动的电子表格上打印所有超链接的word文档。

单元格A1：A200包含超链接。我想打开一个隐藏的Word应用程序 - 检查单元格A1的超链接 - 如果存在打开链接 - 打印文档 - 关闭文档 - 移动到下一个单元格A2 - 检查A2等中的超链接...最后关闭隐藏的单词应用程序。如果单元格没有超链接移动到下一个单元格而没有任何错误。

我玩得很开心，而且我没有走得太远，所以我希望有人能够帮助我。

并非所有文档都是单词，有些是开放式.ods文件，所以如果我可以打开超链接并使用本机程序打印然后关闭会更好但我很乐意将所有.ods转换为.doc来制作它更容易工作。

谢谢！

编辑：此代码只会打印随机链接。

Sub ExportToWordAndPrint()

Const Ttl As String = "Word Print"
Dim cell As Range, rng As Range
Dim FullNameOfFile As String
Dim WordApp As Object, MyDoc As Object

On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then Set WordApp = CreateObject("Word.Application")
On Error GoTo 0

If WordApp Is Nothing Then
    MsgBox "Microsoft Word is not installed on this computer - operation cancelled.", vbCritical + vbOKOnly, Ttl
    Exit Sub
End If

WordApp.Visible = False
Set rng = Selection

For Each cell In rng

    On Error Resume Next
        FullNameOfFile = ""
        FullNameOfFile = cell.Hyperlinks(1).Address
    On Error GoTo 0

    If FullNameOfFile <> "" Then 'cell may not have contained a Hyperlink

        If Dir(FullNameOfFile) <> "" Then 'cell may contain a Hyperlink, but the file itself may not exist

            With WordApp
                Set MyDoc = .documents.Open(Filename:=FullNameOfFile)
                MyDoc.PrintOut
                .ActiveWindow.Close SaveChanges:=False
            End With

        End If

    End If

Next cell

Set WordApp = Nothing

End Sub

编辑为代码以输入调试行。在Next Cell上方删除了两个End If行以避免编译错误。

Sub ExportToWordAndPrint()

Const Ttl As String = "Word Print"
Dim cell As Range, rng As Range
Dim FullNameOfFile As String
Dim WordApp As Object, MyDoc As Object

On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then Set WordApp = CreateObject("Word.Application")
On Error GoTo 0

If WordApp Is Nothing Then
    MsgBox "Microsoft Word is not installed on this computer - operation cancelled.", vbCritical + vbOKOnly, Ttl
    Exit Sub
End If

WordApp.Visible = False
Set rng = Selection

For Each cell In rng

    On Error Resume Next
        FullNameOfFile = ""
        FullNameOfFile = cell.Hyperlinks(1).Address
    On Error GoTo 0

    If FullNameOfFile <> "" Then Debug.Print cell.Address & " failed, appears to have no hyperlink"

        If Dir(FullNameOfFile) <> "" Then Debug.Print cell.Address & " failed, appears to have wrong filename"

                Debug.Print cell.Address & " should print"

            With WordApp
                Set MyDoc = .documents.Open(Filename:=FullNameOfFile)
                MyDoc.PrintOut
                .ActiveWindow.Close SaveChanges:=False
            End With

    Next cell

Set WordApp = Nothing

End Sub

第一个链接现在只打印而不是其他链接。问题是我没有选择范围吗？不确定把它放在哪里？

感谢大家的帮助！

Answer 1

据我所知，你的帖子中的DOC文件打印好了。

可用于打印ODS文档的方法是使用命令行使OpenOffice打印文档。如本网站所示： https://wiki.openoffice.org/wiki/Documentation/FAQ/General/Is_there_a_way_to_print_a_batch_of_files_without_opening_each_of_them_in_OOo%3F

OfficeID = Shell "openoffice -pt ""PRINTER-NAME"" FILENAME"

如果应用程序在完成后未退出，则可以使用OfficeID终止该进程。例如Shell "TASKKILL /PID " & CStr(OfficeID)。

注意：我自己没试过，但是应该让你开始。

<强>更新

以下是我尝试编辑的代码，但是一些没有阅读帖子的审阅者还原了它，这就是为什么你没有看到它，这是添加Debug行的正确方法：

Sub ExportToWordAndPrint()

Const Ttl As String = "Word Print"
Dim cell As Range, rng As Range
Dim FullNameOfFile As String
Dim WordApp As Object, MyDoc As Object

On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then Set WordApp = CreateObject("Word.Application")
On Error GoTo 0

If WordApp Is Nothing Then
    MsgBox "Microsoft Word is not installed on this computer - operation cancelled.", vbCritical + vbOKOnly, Ttl
    Exit Sub
End If

WordApp.Visible = False
Set rng = Range("A4:A200")

For Each cell In rng

    On Error Resume Next
        FullNameOfFile = ""
        FullNameOfFile = cell.Hyperlinks(1).Address
    On Error GoTo 0

    If FullNameOfFile <> "" Then 'cell may not have contained a Hyperlink

        If Dir(FullNameOfFile) <> "" Then 'cell may contain a Hyperlink, but the file itself may not exist

            'Debug.print cell.address & " should print"    'THIS ONE ADDED
            With WordApp
                Set MyDoc = .documents.Open(Filename:=FullNameOfFile)
                MyDoc.PrintOut
                .ActiveWindow.Close SaveChanges:=False
            End With
        Else         'THIS ONE ADDED
            'Debug.print cell.address & " failed, appears to have wrong filename" 
        End If
    Else             'THIS ONE ADDED
        'Debug.print cell.address & " failed, appears to have no hyperlink"    
    End If

Next cell

WordApp.Quit SaveChanges:=wdDoNotSaveChanges
Set WordApp = Nothing

End Sub

Excel宏以打印超链接的Word文档

1 个答案: