2

以下代码一直运行到标记的行。然后 Word 会显示锁定文件以进行编辑/打开只读提示。我需要能够编辑文档（这是代码的重点）。

抱歉，代码块太长了——我觉得展示所有内容很重要，这样更容易找到问题。

对于多个记录集，代码也有点笨拙，如果有人有更好的想法会喜欢这里。

Option Explicit
Option Compare Database

Sub InputSafetyData()

Dim dbCur As Database

Dim appCur As Word.Application
Dim docCur As Word.Document
Dim dlgCur As FileDialog

Dim rngCcCur As Range

Dim varDlgCur As Variant

Dim strDocName As String
Dim strDocPath As String
Dim strSQL As String

Dim rsIt As DAO.Recordset
Dim rsHc As DAO.Recordset
Dim rsHz As DAO.Recordset
Dim rsPr As DAO.Recordset


Dim strHc As String
Dim strHz As String
Dim strPr As String

Set dbCur = CurrentDb()
Set dlgCur = Application.FileDialog(msoFileDialogFolderPicker)

With dlgCur
    .AllowMultiSelect = False
    If .Show <> -1 Then End
    varDlgCur = .SelectedItems(1)
End With

strDocPath = CStr(varDlgCur) & "\"
strDocName = Dir(strDocPath & "*.docx")

Set appCur = New Word.Application
    appCur.Visible = True
Set dlgCur = Nothing

Do While strDocName <> ""

    'Runs as far here
    Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, ReadOnly:=False, Visible:=False)

    If docCur.ReadOnly = False Then

        Set rngCcCur = docCur.ContentControls(6).Range
        rngCcCur = ""
        appCur.ActiveDocument.Tables.Add Range:=rngCcCur, NumRows:=1, NumColumns:=4
        With rngCcCur.Tables(0)
            If .Style <> "Table Grid" Then
                .Style = "Table Grid"
            End If
            .ApplyStyleHeadingRows = True
            .ApplyStyleLastRow = False
            .ApplyStyleFirstColumn = True
            .ApplyStyleLastColumn = False
            .ApplyStyleRowBands = True
            .ApplyStyleColumnBands = False
            .Style = "Light Shading"
            .AutoFitBehavior wdAutoFitWindow
            .Cell(1, 1).Range.InsertAfter "Item"
            .Cell(1, 2).Range.InsertAfter "Hazcard"
            .Cell(1, 3).Range.InsertAfter "Hazard"
            .Cell(1, 4).Range.InsertAfter "Precaution"

            'select distinct item based on filename
            strSQL = "Select Distinct Item From IHR where filename is"
            strSQL = strSQL & strDocName
            Set rsIt = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
            If Not (rsIt.BOF And rsIt.EOF) = True Then
                While Not rsIt.EOF
                    .Rows.Add
                    .Cell(rsIt.AbsolutePosition + 2, 1).Range.InsertAfter rsIt.Fields(1).Value
                    'select distinct hazcard based on item
                    strSQL = "Select Distinct Hazcard From IHR where item is"
                    strSQL = strSQL & rsIt.Fields(1).Value
                    Set rsHc = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
                    If Not (rsHc.BOF And rsHc.EOF) = True Then
                        While Not rsHc.EOF
                            strHc = strHc & " " & rsHc.Fields(2).Value
                            .Cell(rsIt.AbsolutePosition + 2, 2).Range.InsertAfter strHc
                            rsHc.MoveNext
                        Wend
                    End If
                    rsHc.Close
                    Set rsHc = Nothing

                    'select distinct hazard based on item
                    strSQL = "Select Distinct Hazard From IHR where item is"
                    strSQL = strSQL & rsIt.Fields(1).Value
                    Set rsHz = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
                    If Not (rsHz.BOF And rsHz.EOF) = True Then
                        While Not rsHz.EOF
                        strHc = strHz & " " & rsHz.Fields(2).Value
                            .Cell(rsIt.AbsolutePosition + 2, 3).Range.InsertAfter strHz
                            rsHz.MoveNext
                        Wend
                    End If
                    rsHz.Close
                    Set rsHz = Nothing

                    'select distinct precaution based on item
                    strSQL = "Select Distinct Precaution From IHR where item is"
                    strSQL = strSQL & rsIt.Fields(1).Value
                    Set rsPr = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
                    If Not (rsPr.BOF And rsPr.EOF) = True Then
                        While Not rsPr.EOF
                            strPr = strPr & " " & rsPr.Fields(4).Value
                            .Cell(rsIt.AbsolutePosition + 2, 4).Range.InsertAfter strPr
                            rsPr.MoveNext
                        Wend
                    End If
                    rsPr.Close
                    Set rsPr = Nothing

                    rsIt.MoveNext
                Wend
            End If
        End With
        rsIt.Close
        Set rsIt = Nothing
    Debug.Print (docCur.Name)
    docCur.Save
    End If
    docCur.Close
    Set docCur = Nothing
    strDocName = Dir
Loop

Set appCur = Nothing

End Sub
4

2 回答 2

4

关注眼前的问题---“无法打开word文件进行编辑”。

我创建了一个文件夹，C:\share\testdocs\并添加了 Word 文档。下面的代码示例使用一个常量作为文件夹名称。我想要一个简单的测试，所以摆脱了FileDialog. 我还丢弃了所有记录集代码。

我在打开 Word 文档时使用了 Visible:=True。我不明白为什么您的 Word 应用程序可见，但个别文档不可见。无论逻辑是什么，我都选择让它们可见，这样我就可以观察到内容的变化。

我用 Access 2007 对此进行了测试，它可以正常工作。如果它不适合您，请仔细检查当前用户对文件夹和目标文档的文件系统权限。

Public Sub EditWordDocs()
Const cstrFolder As String = "C:\share\testdocs\"
Dim appCur As Word.Application
Dim docCur As Word.Document
Dim strDocName As String
Dim strDocPath As String
Dim strMsg As String

On Error GoTo ErrorHandler

strDocPath = cstrFolder
strDocName = Dir(strDocPath & "*.docx")

Set appCur = New Word.Application
appCur.Visible = True

Do While strDocName <> ""
    Debug.Print "strDocName: " & strDocName
    Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
        ReadOnly:=False, Visible:=True)
    Debug.Print "FullName: " & docCur.FullName
    Debug.Print "ReadOnly: " & docCur.ReadOnly
    ' add text to the document ... '
    docCur.content = docCur.content & vbCrLf & CStr(Now)
    docCur.Close SaveChanges:=wdSaveChanges
    Set docCur = Nothing
    strDocName = Dir
Loop

ExitHere:
    On Error Resume Next
    appCur.Quit SaveChanges:=wdDoNotSaveChanges
    Set appCur = Nothing
    On Error GoTo 0
    Exit Sub

ErrorHandler:
    strMsg = "Error " & Err.Number & " (" & Err.Description _
        & ") in procedure EditWordDocs"
    MsgBox strMsg
    Debug.Print strMsg
    GoTo ExitHere
End Sub

假设您能够克服只读问题，我认为您将面临更多挑战。你的SELECT陈述在我看来非常可疑...... 

'select distinct item based on filename '
strSQL = "Select Distinct Item From IHR where filename is"
strSQL = strSQL & strDocName

例如，如果strDocName包含“ temp.docx ”，strSQL将包含此文本...

Select Distinct Item From IHR where filename istemp.docx

这不是一个有效的 SELECT 语句。我想你可能需要更多这样的东西......

SELECT DISTINCT [Item] FROM IHR WHERE filename = 'temp.docx'

Item是一个保留字，所以我将它括在方括号中以避免混淆数据库引擎。使用相等运算符 ( =) 而不是 "is" 进行字符串比较。

Debug.Print它对您的字符串非常有用strSQL，因此您可以直接检查您要求数据库引擎运行的完整语句......查看它而不是依靠您的想象力来猜测它的样子。当它失败时，您可以从立即窗口复制Debug.Print输出并将其粘贴到新查询的 SQL 视图中以进行测试。

但是，在您克服 Word 文档的只读问题之前，这些 Access 查询问题并不重要。

为了跟进可见性与只读的问题，我的代码打开了 Word 文档并在包含这两个更改中的一个或两个时对其进行了修改，而不会引发错误：

appCur.Visible = False

和

Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
    ReadOnly:=False, Visible:=False)
于 2012-09-09T17:13:30.910 回答
-1

我对只读打开的文件有同样的问题。您可以尝试输入以下代码：

appcur.ActiveWindow.View.ReadingLayout = False
于 2016-04-12T17:17:25.473 回答