I want to check a folder if a rotated version of my images exists, if it doesn't I want to use ImageMagick to automatically do it for me (or another program if it would be a better option). This is my code:
Dim imageDomain As String
Dim imagePath As String
Dim rotatePath As String
Dim rotateBool As Boolean
Dim imageRotator As Integer
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT Afbeelding FROM Products")
imageDomain = CurrentProject.Path & "\folder\"
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
Do Until rs.EOF = True
If Not IsNull(rs!Afbeelding) Then
rotatePath = imageDomain & "rotate\" & rs!Afbeelding
rotateBool = Len(Dir(rotatePath))
If Not rotateBool Then
imagePath = imageDomain & rs!Afbeelding
imageRotator = Shell("cmd.exe /c convert.exe -rotate ""270"" " & imagePath & " " & rotatePath)
End If
End If
rs.MoveNext
Loop
Else
MsgBox "There are no records in the recordset."
End If
rs.Close
Set rs = Nothing
The code gives an overflow error at the shell command. How can I selectively rotate the images I want with ImageMagick using VBA? Using a batch file would rotate all images in the folder?
The COM+ object did the trick.
Dim img As Object
Set img = CreateObject("ImageMagickObject.MagickImage.1")
In the loop:
imageRotator = img.Convert(imagePath, "-rotate", "270", rotatePath)
Related
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 want to be able to view the contents of my access database's laccdb file through VBA so I can use it to alert users (through a button) who else is in the database.
I specifically don't want to use a 3rd Party tool. I have tried using:
Set ts = fso.OpenTextFile(strFile, ForReading)
strContents = ts.ReadAll
This works fine if only 1 user is in the database. But for multiple users it gets confused by the presumably non-ASCII characters and goes into this kind of thing after one entry:
Does anyone have any suggestions? It's fine if I just open the file in Notepad++...
Code eventually used is as follows (I didn't need the title and have removed some code not being used):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Open "Data Source=" & CurrentDb.Name
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
While Not rs.EOF
Debug.Print rs.Fields(0)
rs.MoveNext
Wend
End Sub
I found this which should help, it's not actually reading the ldb file, but it has the info that you need (Source: https://support.microsoft.com/en-us/kb/198755):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=c:\Northwind.mdb"
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=c:\Northwind.mdb"
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the current database.
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Wend
End Sub
I put together some code to read through the lock file and output a message listing users currently using the system.
Trying to read the whole file in at once seems to result in VBA treating the string as Unicode in the same way notepad does so I read in character by character and filter out non printing characters.
Sub TestOpenLaccdb()
Dim stm As TextStream, fso As FileSystemObject, strLine As String, strChar As String, strArr() As String, nArr As Long, nArrMax As Long, nArrMin As Long
Dim strFilename As String, strMessage As String
strFilename = CurrentProject.FullName
strFilename = Left(strFilename, InStrRev(strFilename, ".")) & "laccdb"
Set fso = New FileSystemObject
Set stm = fso.OpenTextFile(strFilename, ForReading, False, TristateFalse) 'open the file as a textstream using the filesystem object (add ref to Microsoft Scripting Runtime)
While Not stm.AtEndOfStream 'Read through the file one character at a time
strChar = stm.Read(1)
If Asc(strChar) > 13 And Asc(strChar) < 127 Then 'Filter out the nulls and other non printing characters
strLine = strLine & strChar
End If
Wend
strMessage = "Users Logged In: " & vbCrLf
'Debug.Print strLine
strArr = Split(strLine, "Admin", , vbTextCompare) 'Because everyone logs in as admin user split using the string "Admin"
nArrMax = UBound(strArr)
nArrMin = LBound(strArr)
For nArr = nArrMin To nArrMax 'Loop through all machine numbers in lock file
strArr(nArr) = Trim(strArr(nArr)) 'Strip leading and trailing spaces
If Len(strArr(nArr)) > 1 Then 'skip blank value at end
'Because I log when a user opens the database with username and machine name I can look it up in the event log
strMessage = strMessage & DLast("EventDescription", "tblEventLog", "[EventDescription] like ""*" & strArr(nArr) & "*""") & vbCrLf
End If
Next
MsgBox strMessage 'let the user know who is logged in
stm.Close
Set stm = Nothing
Set fso = Nothing
End Sub
Overall Goal:
Pull all files from folder > format files in staging table > copy staging table to master table > kill staging table > rinse and repeat until all files have been taken from folder, formatted and put into the master table.
Issue:
I have apparently not taken into account that some of the files sent to me will have blank worksheets (rather they may have a value that says "No Data" in cell A1). When my macro hits the "No Data" or blank sheet I get a Null error (94).
What I've tried:
strF1Data = Nz(!ref_val)
strF1Data = Nz(!ref_val,"")
Suspicions:
I think I can update the SQL UPDATE line to allow Nulls, but I feel like a more efficient solution would be to skip if null. However I have tried modifying the Do Until statement and had no luck...
Possibly Worth Mentioning:
The files have multiple worksheets. I learned this the hard way in finding this error on a random worksheet between several other worksheets that did have data.
Code: (to help save some space, I'm only giving the call files bit and formatting piece, I don't think the other pieces will be of any use. However if you would like them then let me know.)
The overall macro (see next code sections for piece with error):
Sub Pull_File_into_Staging_Table()
'Process:
'1 - Loop through all files saved to specified folder making an internal list of the files
'2 - Paste one files content to staging table at a time
'3 - Format the information in the staging table
'4 - Copy formatted staging table to 1Compare Table (master table)
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\Users\USER\Desktop\Test\"
Dim rs As DAO.Recordset ' Moved from below
Dim db As DAO.Database
Set db = CurrentDb
'Loop through the folder & build file list
strFile = Dir(path & "*.xls")
While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend
'see if any files were found
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If
'cycle through the list of files
For intFile = 1 To UBound(strFileList)
filename = path & strFileList(intFile)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "Stage", filename, False
Call Format_Staging_Table
Call Copy_from_Stage_to_Master
Call Clear_Staging_Table
Next intFile
DoCmd.SetWarnings True
End Sub
The piece with the issue:
Sub Format_Staging_Table()
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\Users\USER\Desktop\Test\"
Dim rs As DAO.Recordset ' Moved from below
Dim db As DAO.Database
Set db = CurrentDb
CurrentDb.Execute ("ALTER TABLE Stage ADD COLUMN UPC Text, SR_Profit_Center Text, SR_Super_Label Text, SAP_Profit_Center Text, SAP_Super_Label Text;")
CurrentDb.TableDefs("Stage").Fields("F1").Name = "ref_val"
Dim ref_val As String
Set rs = db.OpenRecordset("SELECT TOP 1 ref_val FROM Stage;", dbOpenDynaset)
ref_val = rs.Fields(0).Value
rs.Close
db.Execute "DELETE FROM [Stage] WHERE ref_val = '" & ref_val & "';"
Const YOUR_TABLE_NAME As String = "Stage"
Dim SQL_UPDATE_DATA As String
SQL_UPDATE_DATA = "SELECT *, ';' & '" & ref_val & "' FROM [" & YOUR_TABLE_NAME & "] WHERE SR_Profit_Center Is Null"
Dim strF1Data As String
Dim varData As Variant
Set rs = CurrentDb.OpenRecordset(SQL_UPDATE_DATA)
With rs
Do Until .EOF
strF1Data = !ref_val
varData = Split(strF1Data, ";")
If UBound(varData) = 4 Then
.Edit
!ref_val = ref_val
!UPC = varData(0)
!SR_Profit_Center = varData(1)
!SR_Super_Label = varData(2)
!SAP_Profit_Center = varData(3)
!SAP_Super_Label = varData(4)
.Update
End If
.MoveNext
Loop
.Close
End With
Set rs = Nothing
End Sub
Also I'm aware of the extra variable pieces, I will clean it up once I get it working.
File Examples:
Working File:
CE16041901
00791558441123;US1K100017;CGR;US1K100001;UNKNOW
00791558442328;US1K100017;CGR;US1K100001;UNKNOW
00791558440720;US1K100017;CGR;US1K100001;UNKNOW
00791558444629;US1K100017;CGR;US1K100001;UNKNOW
00791558440522;US1K100017;CGR;US1K100001;UNKNOW
00791558443325;US1K100017;CGR;US1K100001;UNKNOW
Not Working File:
CE16042001
00791558334128;US1K100017;CGR;US1K100001;UNKNOW
00791558159523;US1K100017;CGR;US1K100001;UNKNOW
00602547736604;US1A100018;UR;US1A100018;US-RU
I appreciate any help. I ran with this as far as I could, but I am still very much a novice when it comes to access and vb. If you need more information or clarification please let me know and I'll do my best to provide/explain.
No need to touch the staging table functions. Simply conditionally populate the strFileList array depending if Excel workbooks' first sheet contains No Data or empty cell. Recall Access VBA has complete access to all Excel objects via COM interface or Excel VBA reference and so can iteratively open workbooks. Hence, adjust your While/Wend loop accordingly:
Sub Pull_File_into_Staging_Table()
'...same code...
Dim objXL As Object
Dim wb As Object
Set objXL = CreateObject("Excel.Application")
strfile = Dir(Path & "*.xls")
While strfile <> ""
Set wb = objXL.Workbooks.Open(Path & strfile)
If wb.Sheets(1).Range("A1") <> "No Data" AND wb.Sheets(1).Range("A1") <> "" Then
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strfile
End If
strfile = Dir()
wb.Close False
Set wb = Nothing
Wend
'...
So I have this search form that filters projects based on the designer type. The designer can be internal, external, or combination. It was originally done using a combobox. I was asked to make it so that the user can filter by multiple options, so I changed it to a listbox with the idea of using the multiselect option.
The listbox works fine, until I set the multiselct option to anything besides none. Then, all the projects are returned instead of the ones that are selected.
I'm not very experienced in Access or VBA so any assistance would be greatly appreciated. The following is the code for this section.
Private Sub toDesignerExcel_Click()
Dim db As DAO.Database
Dim rs1, rs2 As DAO.Recordset
Dim sSQL1, sSQL2, SourceExcel, FileName, Path As String
Set db = CurrentDb
sSQL1 = "Select ExcelPath from tblBackendFiles where Setting = 'ExcelDesignerParameters'"
sSQL2 = "Select Setting from tblBackendFiles where Code = 'SourceExcel'"
Set rs1 = db.OpenRecordset(sSQL1)
FileName = Nz(rs1!ExcelPath, "")
Set rs2 = db.OpenRecordset(sSQL2)
SourceExcel = Nz(rs2!Setting, "")
Path = SourceExcel + "\" + FileName
rs1.Close
rs2.Close
db.Close
Set rs1 = Nothing
Set rs2 = Nothing
Set db = Nothing
Shell "C:\WINDOWS\explorer.exe """ & Path, vbNormalFocus
End Sub
EDIT:
And also,
If Forms(formName).txtDesigner <> "" And Not IsNull(Forms(formName).txtDesigner) Then
If selEngConditions <> "" Then
selEngConditions = selEngConditions & " AND "
End If
selEngConditions = selEngConditions & "[Activity].[GWPDesigner] = '" & Forms(formName).txtDesigner & "'"
End If
I would do something like this :
Private Sub toDesignerExcel_Click()
Dim db As DAO.Database
Dim rs1, rs2 As DAO.Recordset
Dim sSQL1, sSQL2, SourceExcel, FileName, Path As String
Set db = CurrentDb
sSQL1 = "Select ExcelPath from tblBackendFiles where Setting = 'ExcelDesignerParameters' And [Tblbackendfiles] = '"
sSQL2 = "Select Setting from tblBackendFiles where Code = 'SourceExcel' And [Tblbackendfiles] = '"
For Each it In Me.ListBoxName.ItemsSelected
Set rs1 = db.OpenRecordset(sSQL1 & it & "'")
FileName = Nz(rs1!ExcelPath, "")
Set rs2 = db.OpenRecordset(sSQL2 & it & "'")
SourceExcel = Nz(rs2!Setting, "")
Path = SourceExcel + "\" + FileName
Shell "C:\WINDOWS\explorer.exe """ & Path, vbNormalFocus
rs1.Close
rs2.Close
Set rs1 = Nothing
Set rs2 = Nothing
Next it
db.Close
Set db = Nothing
End Sub
Where you basically iterate over all the selected items in the listbox. This adds each selected item from the listbox in the where clause of the query.
You can also try concatenating all the values and changing the query to something like :
And [Tblbackendfiles] In (" & comma_separated_list & ")
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