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は予約語なので、db エンジンの混乱を避けるために角括弧で囲みました。=文字列の比較には、"is" の代わりに等値演算子 ( ) を使用します。

これは文字列にとって非常に便利ですDebug.Print。strSQLそのため、db エンジンに実行を依頼している完成したステートメントを直接調べることができます。想像力に頼ってどのように見えるかを推測する代わりに、それを表示できます。失敗した場合はDebug.Print、イミディエイト ウィンドウから出力をコピーして、テスト用に新しいクエリの SQL ビューに貼り付けることができます。

ただし、これらの Access クエリの問題は、Word 文書の読み取り専用の問題を解決できるまで問題になりません。

可視性と読み取り専用の問題をフォローアップするために、コードで Word 文書を開き、次の 2 つの変更のいずれかまたは両方を含めたときにエラーをスローすることなくそれらを変更しました。

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 に答える