Im trying to use the replaceline function to update code in Access VBA module. it keeps coming up with a compile error. Ive checked that the VBA Extension are selected and compared it to other examples that I have looked up.
this is the first time that Ive used this type of function, so I haven't fully got my head around them.
code below
Sub ReplaceCodeModuleText(strModule As String, strFindWhat As String, strReplaceWith As String)
'FUNCTION:
' Search the code module for specific text
' Replace with new text
Dim VBProj As VBProject
Dim VBComp As VBComponent
Dim CodeMod As CodeModule
Dim SL As Long ' start line
Dim EL As Long ' end line
Dim SC As Long ' start column
Dim EC As Long ' end column
Dim strCodeLine As String
Dim vDummy As Variant
Dim Found As Boolean
Set VBProj = Application.VBE.ActiveVBProject
Set VBComp = VBProj.VBComponents(strModule)
Set CodeMod = VBComp.CodeModule ' '.CodeModule
With CodeMod
SL = 1: EL = .CountOfLines
SC = 1: EC = 255
Found = .Find(Target:=strFindWhat, StartLine:=SL, StartColumn:=SC, _
EndLine:=EL, EndColumn:=EC, _
wholeword:=True, MatchCase:=False, patternsearch:=False)
If Found Then
strCodeLine = CodeMod.Lines(SL, 1)
strCodeLine = Replace(strCodeLine, strFindWhat, strReplaceWith, Compare:=vbTextCompare) 'not case sensitive = vbTextCompare
.ReplaceLine(SL, strCodeLine)
Debug.Print "Successfully Replaced: " & strFindWhat & " in VBA Module: " & strModule & " with : " & strReplaceWith
Else
Debug.Print "Did not find: " & strFindWhat;
End If
End With
End Sub
.ReplaceLine(SL, strCodeLine)
must be either
Call .ReplaceLine(SL, strCodeLine)
or
.ReplaceLine SL, strCodeLine
Related
I have working code that requests information from a website.
When I send the file to another PC and run the code, I get:
"Run-time error'91': Object variable or With block variable not set"
I ensured:
Macro security levels are the same (Enable all macros & trust access to VBA project object model)
All the checked boxes in VBA editor > Tools > References are the same (Specifically Microsoft HTML Object Library & Microsoft XML, V6.0 is checked)
Sub Macro1()
Dim request As Object
Dim response As String
Dim html As New HTMLDocument
Dim website As String
Dim Current As Variant
website = "https://www.thalia.de/shop/home/artikeldetails/A1062020980"
Set request = CreateObject("MSXML2.XMLHTTP")
request.Open "GET", website, False
request.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
request.send
response = StrConv(request.responseBody, vbUnicode)
html.body.innerHTML = response
Current = html.getElementsByClassName("element-text-standard value").Item(0).innerText
MsgBox (Current)
End Sub
The line on which I get the error:
Current = html.getElementsByClassName("element-text-standard value").Item(0).innerText
WinHttp
I've tried a ton of various solutions, in the end, it came just to replacing MSXML2.XMLHTTP with WinHttp.WinHttpRequest.5.1 to make it work on my computer. While I was researching, I rewrote the whole thing a little bit. I'm a noob at this so I can't explain why one works and the other does not.
Option Explicit
Sub Macro1()
Const URL As String _
= "https://www.thalia.de/shop/home/artikeldetails/A1062020980"
'Const URL As String _
= "https://www.thalia.de/shop/home/artikeldetails/A1060523771"
Const ClassName As String _
= "element-text-standard value"
Dim WhrResponseText As String
WhrResponseText = GetWhrResponseText(URL)
If Len(WhrResponseText) = 0 Then
MsgBox "Could not get a response.", vbExclamation
Exit Sub
End If
' ' Write the response string to a worksheet.
' Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Dim arr() As String: arr = Split(WhrResponseText, vbLf)
' ws.Range("A1").Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
Dim Elements As Object
With CreateObject("htmlfile")
.body.innerHTML = WhrResponseText
Set Elements = .getElementsByClassName(ClassName)
End With
' Using 'Length' to determine if a result was found and returning
' the first element.
Dim Result As Variant
With Elements
If .Length > 0 Then
Result = .Item(0).innerText
MsgBox Result
Else
MsgBox "Nothing found."
End If
End With
Dim i As Long
' Loop through the elements using 'For Each... Next'.
Dim Element As Object
For Each Element In Elements
Debug.Print i, Element.innerText
i = i + 1
Next Element
' ' Loop through the elements using 'For... Next'.
' With Elements
' For i = 0 To .Length - 1
' Debug.Print i, .Item(i).innerText
' Next i
' End With
End Sub
Function GetWhrResponseText( _
ByVal URL As String) _
As String
Const ProcName As String = "GetWhrResponseText"
On Error GoTo ClearError
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", URL, False
.send
GetWhrResponseText = StrConv(.responseBody, vbUnicode)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
I have a function in VBA that replaces code on while the code is running. I am usign "CodeModule.ReplaceLine" to do this. this is primarily for the updating of a cookie in a web address. the function that is being updated is not running when the text line is being re-written.
I initially used in in access 2013 but I now use 2016.
I suspect it's because the code is being changed after it has been compiled. but im not sure why there is a problem now and not before. the code is below.
Sub ReplaceCodeModuleText(sModule As String, sProcName As String, sFindWhat As String, sReplaceWith As String)
'FUNCTION:
' Search the code module for specific text
' Replace with new text
Dim VBProj As VBProject
Dim VBComp As VBComponent
Dim CodeMod As CodeModule
Dim Proc As Procedure
Dim SL As Long ' start line
Dim EL As Long ' end line
Dim SC As Long ' start column
Dim EC As Long ' end column
Dim sCodeLine As String
Dim vDummy As Variant
Dim Found As Boolean
Set VBProj = Application.VBE.ActiveVBProject
Set VBComp = VBProj.VBComponents(sModule)
Set CodeMod = VBComp.CodeModule ' '.CodeModule
With CodeMod
SL = .ProcStartLine(sProcName, vbext_pk_Proc)
EL = SL + .ProcCountLines(sProcName, vbext_pk_Proc) - 1
SC = 1: EC = 255
Found = .Find(Target:=sFindWhat, StartLine:=SL, StartColumn:=SC, _
EndLine:=EL, EndColumn:=EC, _
wholeword:=True, MatchCase:=False, patternsearch:=False)
If Found Then
sCodeLine = CodeMod.Lines(SL, 1)
sCodeLine = Replace(sCodeLine, sFindWhat, sReplaceWith, Compare:=vbTextCompare) 'not case sensitive = vbTextCompare
Call .ReplaceLine(SL, sCodeLine)
Debug.Print "Successfully Replaced: " & sFindWhat & " in VBA Module: " & sModule & " with : " & sReplaceWith
Else
Debug.Print "Did not find: " & sFindWhat;
End If
End With
End Sub
I have a table that contains a paths of multi pdfs file...now I need a VBA code to merge all these files to a single pdf file.
Notice:-the number of pdfs files to be merged varies from time to time.
Sub Combine_PDFs_Demo()
Dim i As Integer 'counter for records
Dim x As Integer
Dim strNPDF As String
Dim bSuccess As Boolean
Dim DB As Database
Dim RS As Recordset
Set DB = CurrentDb
Set RS = DB.OpenRecordset("SELECT[paths] from scantemp ")
strNPDF = CurrentProject.Path & "\request_pic\" & (request_no) & ".pdf"
RS.MoveLast
DB.Recordsets.Refresh
i = RS.RecordCount
RS.MoveFirst
Dim strPDFs() As String
ReDim strPDFs(0 To i)
strPDFs(0) = RS![paths]
RS.MoveNext
For i = 1 To i - 1
strPDFs(i) = RS![paths]
bSuccess = MergePDFs(strPDFs, strNPDF)
Next i
If bSuccess = False Then MsgBox "Failed to combine all PDFs", vbCritical, "Failed to Merge PDFs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp" 'delete all paths from table scantemp after converted it to pdf
DoCmd.SetWarnings True
RS.Close
Set RS = Nothing`enter code here`
public Function MergePDFs(arrFiles() As String, strSaveAs As String) As Boolean
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim i As Integer
Dim iFailed As Integer
On Error GoTo NoAcrobat:
'Initialize the Acrobat objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles))) 'open the first file
'Open each subsequent PDF that you want to add to the original
'Open the source document that will be added to the destination
For i = LBound(arrFiles) + 1 To UBound(arrFiles)
objCAcroPDDocSource.Open (arrFiles(i))
If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MergePDFs = True
Else
'failed to merge one of the PDFs
iFailed = iFailed + 1
End If
objCAcroPDDocSource.Close
Next i
objCAcroPDDocDestination.save 1, strSaveAs 'Save it as a new name
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
NoAcrobat:
If iFailed <> 0 Then
MergePDFs = False
End If
On Error GoTo 0
End Function
This uses a list of PDF or PS files to create one PDF. Sorry it's in VB.net and I don't really have time to convert. But it illustrates the concept if you can wade through it. Basically you write the options and file names to a text file then use that file as an argument to Ghostscript.
Private Shared Sub ConvertToPDF(ByVal PSPathFileList As List(Of String), _
ByVal PDFPathName As String, _
ByVal WaitForExit As Boolean, ByVal DeletePS As Boolean)
'check that all files exist
PSPathFileList.ForEach(AddressOf CheckFiles)
'check old pdf file
If IO.File.Exists(PDFPathName) Then
Throw New ApplicationException( _
"PDF cannot be created. File already exists: " & PDFPathName)
End If
'convert engine
Dim myProcInfo As New ProcessStartInfo
myProcInfo.FileName = DanBSolutionsLocation & "Misc\GhostScript\GSWIN32C.EXE"
Debug.Print(myProcInfo.FileName)
'write file names to text file as the list can be very long
Dim tempPath As String = IO.Path.GetDirectoryName(PSPathFileList.Item(0))
Dim fiName2 As String = tempPath & IO.Path.GetFileNameWithoutExtension(PDFPathName) & ".txt"
Dim ft As New StreamWriter(fiName2)
ft.WriteLine("-sDEVICE=pdfwrite -q -dSAFER -dNOPAUSE -sOUTPUTFILE=""" & PDFPathName & """ -dBATCH ")
For i As Long = 0 To PSPathFileList.Count - 1
ft.WriteLine(Chr(34) & PSPathFileList.Item(i) & Chr(34))
Next
ft.Close()
'set args to text file
myProcInfo.Arguments = """#" & fiName2 & """"
'set up for output and errors
myProcInfo.UseShellExecute = False
myProcInfo.RedirectStandardOutput = True
myProcInfo.RedirectStandardError = True
Debug.Print(myProcInfo.Arguments)
'do the conversion
Dim myProc As Process = Process.Start(myProcInfo)
Debug.Print(myProc.StandardOutput.ReadToEnd)
Debug.Print(myProc.StandardError.ReadToEnd)
If WaitForExit Then
'wait for finish; (no more than 60 seconds)
myProc.WaitForExit(60000)
'delete PS
If DeletePS Then
PSPathFileList.ForEach(AddressOf DeleteFiles)
End If
End If
End Sub
Here's VBA code for a single PS to PDF. So between the VB.net above and this below hopefully you can salvage something useful.
Private Sub printToPdfDemo()
'verify printer setup
'be sure to install the PsPrinterInstall module
Call PSPrinterSetup
Dim svPsFileName As String
Dim svPDFName As String
'define names
svPsFileName = "C:\Temp\Input 1.ps"
svPDFName = "C:\Temp\Output 1.PDF"
'save current printer
Dim PrinterInUse As String
PrinterInUse = Application.ActivePrinter
'print to PS
'If Fso.FileExists(svPsFileName) Then Call Fso.DeleteFile(svPsFileName)
Worksheets(1).PrintOut ActivePrinter:=PSPrinterName, PrintToFile:=True, _
PrToFileName:=svPsFileName
'revert to saved printer name
Application.ActivePrinter = PrinterInUse
'convert
Call ConvertToPDF(svPsFileName, svPDFName)
End Sub
Sub ConvertToPDF(ByVal svPsFileName As String, ByVal svPDFName As String)
Dim fso As New FileSystemObject
'Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
Dim folGS As Folder
Dim lcCmd As String
'check inputs
If svPsFileName = "" Or svPDFName = "" Then
Call MsgBox("PS file name or PDF file name is blank in ""ConvertToPDF"" macro", vbExclamation, "Error! Missing Inputs")
Exit Sub
End If
'check file
If Not fso.FileExists(svPsFileName) Then
Call MsgBox(svPsFileName & " file is not found", vbExclamation, "Error! Missing File")
Exit Sub
End If
'check variable
If DanBSolutionsLocation = "" Then DanBSolutionsLocation = GetDanBSolutionsLocation
'delete old file
If fso.FileExists(svPDFName) Then Call fso.DeleteFile(svPDFName)
'get files
Set folGS = fso.GetFolder(DanBSolutionsLocation & "Misc\GhostScript\") 'S:\DanB Solutions\Misc\GhostScript\GSWIN32C.EXE
'GS command
lcCmd = folGS.ShortPath & "\GSWIN32C.EXE " & _
"-q -dNOPAUSE -I" & folGS.ShortPath & "\lib;./fonts " & _
"-sFONTPATH=./fonts -sFONTMAP=" & folGS.ShortPath & "\lib\FONTMAP.GS " & _
"-sDEVICE=pdfwrite -sOUTPUTFILE=" & """" & svPDFName & """" _
& " -dBATCH " & """" & svPsFileName & """"
'convert
Debug.Print lcCmd
Call ShellWait(lcCmd)
'delete PS
If fso.FileExists(svPDFName) Then fso.DeleteFile (svPsFileName)
End Sub
I've found this code that should find two matching pdf-filenames and merges them into 1 pdf-file always in the same order. File 1 then File 2.
The code matches filenames based on the first part of the filename, before the AnotherWord 2014.pdf or before SomeWord.pdf.
Example document name1: John Doe SomeWord.pdf
Example document name2: John Doe AnotherWord 2014.pdf
I use PDF reDirect Pro v2.5.2 (freeware) and a reference to the program.
The problem I have is that the line
Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD
That gives me the error:
User-defined type not defined
How can I fix this?
This is the whole code:
Private Sub Knop0_Click()
'Only works with PDF reDirect Pro v2.5.2
'And needs to have a reference to PDF_reDirect_v2500 and PDF reDirect Pro Remote Control
Dim fs As Object
Dim fld As Object
Dim fld2 As Object
Dim objFile As Object
Dim objFile2 As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD
Dim TempBool As Boolean
Dim Files_to_Merge(1) As String
Dim ObjFileName() As String
Dim CellNameValue() As String
Dim ofn As String
Dim cnv As String
Dim i As Integer
Set fld = fs.GetFolder("C:\pdf")
Set fld2 = fs.GetFolder("C:\pdf\merged")
i = 1
For Each objFile In fld.files
For Each objFile2 In fld.files
CellNameValue() = Split(objFile.Name, " SomeWord.pdf")
cnv = CellNameValue(0)
ObjFileName() = Split(objFile2.Name, " AnotherWord 2014.pdf")
ofn = ObjFileName(0)
Files_to_Merge(1) = fld & "\" & ofn & " AnotherWord 2014.pdf"
Files_to_Merge(0) = fld & "\" & cnv & " SomeWord.pdf"
If StrComp(ofn, cnv) = 0 Then
With oPDF
TempBool = .Utility_Merge_PDF_Files(fld2 & "\" & ofn & " AnotherWord 2014.pdf", Files_to_Merge) 'The file merges here unless it generates an error and goes to If Not TempBool Then...
If Not TempBool Then
MsgBox "An Error Occured: etc."
Else
'Optional
End If
End With
End If
i = i + 1
Next objFile2
i = i + 1
Next objFile
Set oPDF = Nothing
End Sub
As I said in my comments this should work assuming your trial Pro version will still allow this feature.
You just have to make sure you're using the correct version of the object that has been registered on your system.
Can you delete the line Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD and start retyping it from scratch - not copy/pasting? Does the Object for the tool show up in Intellisense as you start typing PDF_Re
Put in the object that it finds PDF_reDirect_v2500 if that's what it is - then type the . and start typing Batch to fill in the last part. You have to use the current version of the object reference.
Compile your code and see if gets past that line
The following code runs as far as the marked line. Word then shows a file locked for editing/ open read only prompt. I need to be able to edit the document (that is the whole point of the code).
Sorry for incredibly long code block - I felt it was important to show everything so that it was easier to find the problem.
The code is also kind of clunky with the multiple recordsets, if anyone has any better ideas would love to here them.
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
Focus on the immediate problem --- "Cannot open word file for editing".
I created a folder, C:\share\testdocs\, and added Word documents. The code sample below uses a constant for the folder name. I wanted a simple test, so got rid of FileDialog. I also discarded all the recordset code.
I used Visible:=True when opening the Word documents. I didn't understand why you have the Word application visible, but the individual documents not visible. Whatever the logic for that, I chose to make them visible so I could observe the content changes.
I tested this with Access 2007, and it works without errors. If it doesn't work for you, double-check the file system permissions for the current user for both the folder and the target documents.
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
Assuming you're able to get past the read-only problem, I think you have more challenges ahead. Your SELECT statements look highly suspicious to me ...
'select distinct item based on filename '
strSQL = "Select Distinct Item From IHR where filename is"
strSQL = strSQL & strDocName
For example, if strDocName contains "temp.docx", strSQL will contain this text ...
Select Distinct Item From IHR where filename istemp.docx
That is not a valid SELECT statement. I think you may need something more like this ...
SELECT DISTINCT [Item] FROM IHR WHERE filename = 'temp.docx'
Item is a reserved word, so I enclosed it in square brackets to avoid confusing the db engine. Use the equality operator (=) instead of "is" for your string comparisons.
It is extremely useful to Debug.Print your strSQL string, so that you may directly examine the completed statement you're asking the db engine to run ... view it instead of relying on your imagination to guess what it looks like. And when it fails, you can copy the Debug.Print output from the Immediate window and paste it into SQL View of a new query for testing.
However, those Access query issues don't matter until you can get past the read-only issue with your Word documents.
To follow up on the issue of visibility vs. read-only, my code opened the Word documents and modified them without throwing errors when I included either or both of these two changes:
appCur.Visible = False
and
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
ReadOnly:=False, Visible:=False)
I had the same problem with a file opened read only. You can try putting in the following code:
appcur.ActiveWindow.View.ReadingLayout = False