Method 'LoadFromText' of Object 'Application' Failed - ms-access

So I've been at days now trying to solve this bug. After having all functions for Access objects exported, removing binary data from specified fields, and importing Access objects to fresh database, this is the error I'm still having issues with.
Run-time error '-2147417851 (80010105)':
Method 'LoadFromText' of object '_Application' failed.
Edit:
As requested, here is the full function code that handles the import. The error is caused in the "Form" LoadFromText line:
Private Sub Setup_New_Database_File(ByVal srcFileName As String, ByVal destPath As String, ByVal txtDumpPath As String)
' srcFileName: Name of the old datbase file
' destPath: Destination path of where new Access object is created at
' txtDumpPath: Directory housing all exported Access text files
Dim accApp As Access.Application
Set accApp = New Access.Application
' Creating a new Access object
iDate = " (" & Format(Date, "mm-dd-yy") & ")"
newDBName = destPath & srcFileName & iDate & ".accdb"
' Auto-delete existing file with same name
If Dir(newDBName) <> "" Then
SetAttr newDBName, vbNormal
Kill newDBName
End If
With accApp
.DBEngine.CreateDatabase newDBName, DB_LANG_GENERAL, dbVersion120
.OpenCurrentDatabase (newDBName)
.Visible = False
.Echo False ' Hide any other Access windows apart from current
.UserControl = False
' --------------------------------------------------------------------------------------------
'On Error GoTo Err_SetupNewDatabaseFile
' Iterate through the directory containing textfile versions of Access objects created previously from SaveAsText,
' and write back to new Access DB file instance
Dim dirObject As Variant
fp = txtDumpPath & "\" & "*.txt"
dirObject = Dir(fp)
Do While Len(dirObject) > 0
cFilePath = txtDumpPath & "\" & dirObject
' Extract the text file type: [Form_, Module_, Query_, Report_, Script_, Table_]
' Every naming convention only has one "_" character.
fTarget = InStr(dirObject, "_")
fStart = fTarget + 1
cfLength = Len(dirObject)
cFileName = Mid(dirObject, fStart, cfLength) ' E.G: objectname.txt
pTarget = InStrRev(cFileName, ".")
pEnd = pTarget - 1
If dirObject = "Database Linked Tables.txt" Then
' Our Linked Tables are large in data, so opted to add them in via connection.
Dim fso As Object, oFile As Object, cLine As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFile = fso.OpenTextFile(cFilePath, ForReading, False)
Do Until oFile.AtEndOfStream
cLine = oFile.ReadLine
If cLine = "" Or cLine = Null Then
GoTo Next_Iteration 'Moving on...
Else
' Need to check for Driver sources
If cLine = "xResults Local" And Special_Character_Match(cLine, "xResults") = True Then
tPath = DLookup("[Database Path]", "[Tables List]", "[Table Name] = 'xResults'")
accApp.DoCmd.TransferDatabase acLink, "Microsoft Access", tPath, acTable, cLine, cLine, False
ElseIf cLine <> "" Or cLine <> Null Then
' Local vs ODBC:::
option1_path = DLookup("[Database Path]", "[Tables List]", "[Table Name] = '" & cLine & "'")
option2_path = DLookup("[Connect]", "[Tables List]", "[Table Name] = '" & cLine & "'")
If option1_path <> "" Or option1_path <> Null Then
accApp.DoCmd.TransferDatabase acLink, "Microsoft Access", option1_path, acTable, cLine, cLine, False
ElseIf option2_path <> "" Or option2_path <> Null Then
option2_source = DLookup("[MySQL Name]", "[Tables List]", "[Table Name] = '" & cLine & "'")
option2_setTableNameTo = cLine
connectString = "ODBC;" & option2_path & ";"
accApp.DoCmd.TransferDatabase acLink, "ODBC Database", connectString, acTable, option2_source, option2_setTableNameTo
End If
End If
End If 'End of cLine = "" check
Next_Iteration:
Loop
oFile.Close
Set fso = Nothing
Set oFile = Nothing
'-----------------------------------------------------------------------------------------------------------------
Else
' Add all textfiles in txtdump dir to new Access file
accObjectType = Left(dirObject, fTarget - 1) ' E.G: Form
accObjectName = Left(cFileName, pEnd) ' E.G: objectname
' Reconvert accObjectName to its original state
Select Case accObjectType
Case "Form"
MsgBox "File Name: [" & accObjectName & "], Form Name: [" & cFilePath & "]"
'On Error Resume Next
accApp.LoadFromText acForm, accObjectName, cFilePath
Case "Module"
accApp.LoadFromText acModule, accObjectName, cFilePath
Case "Query"
accApp.LoadFromText acQuery, accObjectName, cFilePath
Case "Report"
accApp.LoadFromText acReport, accObjectName, cFilePath
Case "Script"
accApp.LoadFromText acMacro, accObjectName, cFilePath
Case "Table"
accApp.DoCmd.TransferText acImportDelim, , accObjectName, cFilePath, True
End Select
End If
' Next file iteration
NextFileIteration:
dirObject = Dir
Loop
End With
' ---------------------------------------------------------------------------------------------
' Variable Cleanup
accApp.Echo True
accApp.Quit
Set accApp = Nothing
End Sub
And where an example Form text file (with the necessary data removed) is here
Where to differentiate the objects, files in cFilePath follow "\dir...\Form_FormName.txt" format, while accObjectName is just "FormName". The issue I'm having is importing Access forms.
Things I have tried:
- I have removed the "NoSaveCTIWhenDisabled =1" lines from the form files, since in old mdb formats this was causing import issues. (Even with this line on still caused import issues)
- I have also tried removing all blank lines from the text files, in case the command had issues with reading them.
While a small subset of form objects to get imported, not all of them do, resulting in this error. Checking the files themselves to see why, I can't make sense of them since the format looks relatively the same for all of them. What would be a reason for this automation error to occur? All other export/parsing functions seem to run fine...

Related

how i can merge multi pdfs files by using VBA code

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

copyhere doesn't respect overwrite parameter in VBA

I'm writing a VBA code to add files, which are into several folders, into a ZIP file.
This procedure should run automatically, by a scheduled job, and I try to add a parameter to force "yes to all".
In Microsoft support there are some constants but if I add to my code, I don't have the aspected result.
the code is the following
Public Sub ZipFolder(ZipFileName As Variant, _
FolderPath As Variant, _
Optional ByVal FileFilter As String, _
Optional ByVal Overwrite As Boolean = False)
Dim fso As Object, tf As Object
Dim strZIPHeader As String, sFile As String
On Error GoTo done
' create zip file header
strZIPHeader = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, Chr(0))
With CreateObject("Shell.Application")
sFile = Dir(FolderPath, vbNormal)
Do Until sFile = vbNullString
.Namespace(ZipFileName).CopyHere FolderPath & sFile, **"&H10&"**
sFile = Dir
Loop
End With
Set fso = Nothing
Set tf = Nothing
done:
If Err.Number <> 0 Then MsgBox Err.Description, vbApplicationModal + vbInformation
End Sub
The parameter &H10& doesn't work. I have tried with "&0X14&" as well but same result.
Any idea?
Thank you
You can study the article and full code here on exactly this subject:
Zip and unzip files and folders with VBA the Windows Explorer way
You'll see, that shall the file be overwritten, it is simply deleted before proceeding:
If FileSystemObject.FileExists(ZipFile) Then
If Overwrite = True Then
' Delete an existing file.
FileSystemObject.DeleteFile ZipFile, True
' At this point either the file is deleted or an error is raised.
Else
ZipBase = FileSystemObject.GetBaseName(ZipFile)
' Modify name of the zip file to be created to preserve an existing file:
' "Example.zip" -> "Example (2).zip", etc.
Version = Version + 1
Do
Version = Version + 1
ZipFile = FileSystemObject.BuildPath(ZipPath, ZipBase & Format(Version, " \(0\)") & ZipExtension)
Loop Until FileSystemObject.FileExists(ZipFile) = False Or Version > MaxZipVersion
If Version > MaxZipVersion Then
' Give up.
Err.Raise ErrorPathFile, "Zip Create", "File could not be created."
End If
End If
End If

Deploy Access 2007 Database with SQL back end to Citrix for multiple users

Situation:
I recently took IT Support ownership of our Time Tracking database at my company (the old owner left). This was written in Access 2007 and uses SQL Server 2008 R2 Tables and views in the back end. We publish a locked (db.accde) version to our Citrix farm and users access it by logging into a citrix web portal and clicking on the icon for the Access Database. I have a need to move this from once server to a different server so the old one can be sunset. I tried simply copying the file on the existing server to the new server (which is running Office 2010 apps) and creating a new icon on the citrix portal to point to it.
Problem:
Now that it is there only 1 person can open it at a time (used to be usable by multiple users) Also it needs to know who I am (for appropriate permissions within the DB) and it doesn't seem to have a clue. It is giving errors related to the SQL connection. The way it figures out who you are and what permissions you should have is by checking Active Directory and if you belong to the correct NT group then you can have access to additional Forms, if not you only see the basic user forms. Right now everyone who opens it from Citrix only sees the "basic user forms" regardless of the NT Groups they are assigned to.
Question:
I am not an advanced developer when it comes to Access and VB. I also know very little about how Citrix works. I am wondering if when I copied the DB to the new server if there was something I didn't do that should have happened. For instance when you open the "existing link" which opens the "existing Access db" for a brief second there is a CMD screen that pops up and goes away prior to the access DB opening. on the new link that is not happening.
If anyone has any expertise they can toss my way to help me go down the right path of figuring this out it would be greatly appreciated.
For various reasons, it is a VBscript. PowerShell could be used as well.
The "trick" is to use the user's LocalAppData folder to host the accdb file as the user always has been granted full rights here.
It worked from the first attempt. The version number is caused by minor changes, including changed names of the local folders, only.
The users received a link to a read-only copy of the script in a shared folder and - when double-clicked - ran and created a shortcut on the user's desktop for future launch of the application. Users had by default Access 2010 installed so no runtime was needed.
The script carries out these tasks:
creates subfolders in the user's LocalAppData folder
kills the application should it be running
copies the current version of the application to the local folder
copies a second copy (launched by the first for background tasks)
creates/copies a shortcut
writes the security settings for the application in the Registry
launches the application (which then launches the background application)
The result is that the user at each launch updates the application, thus deployment of new application versions is "automatic".
Please study the in-line comments for details.
Option Explicit
' Launch script for PPT test/development/operation.
' Version 1.3.0
' 2013-09-15
' Cactus Data. Gustav Brock
Const DESKTOP = &H10
Const LOCALAPPDATA = &H1C
Dim objFSO
Dim objAppShell
Dim objDesktopFolder
Dim objLocalAppDataFolder
Dim objLocalFolder
Dim objRemoteFolder
Dim strLocalFolder
Dim strRemoteFolder
Dim strDesktopFolder
Dim strLocalAppDataFolder
Dim strLocalAppDataDsgFolder
Dim strLocalAppDataDsgPptFolder
Dim strDsgSubfolder
Dim strPptSubfolder
Dim strPptAppSubfolder
Dim strPptNcSuffix
Dim strAppName
Dim strAppSuffix
Dim strShortcutName
Dim strAppLocalPath
Dim strAppLocalBackPath
Dim strAppRemotePath
Dim strShortcutLocalPath
Dim strShortcutRemotePath
Dim strRegPath
Dim strRegKey
Dim strRegValue
Dim booNoColour
Dim varValue
' Adjustable parameters.
strDsgSubfolder = "DSG"
strPptSubfolder = "PPT"
strPPtNcSuffix = "NC"
' ---------------------------------------------------------------------------------
' Uncomment one folder name only:
'strPptAppSubfolder = "Development"
strPptAppSubfolder = "Operations"
'strPptAppSubfolder = "Test"
' ---------------------------------
' Indicate if the script is for the normal version (0) or the no-colour version (1):
booNoColour = 0
' ---------------------------------------------------------------------------------
strRemoteFolder = "K:\_Shared\Sales Planning\Environments\" & strPptAppSubfolder
If booNoColour = 1 Then
strAppSuffix = strPptNcSuffix
Else
strAppSuffix = ""
End If
strAppName = "SalesPlanningTool" & strAppSuffix & ".accdb"
If strPptAppSubfolder = "Operations" Then
If strAppSuffix = "" Then
strShortcutName = "RunPPT.lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & ".lnk"
End If
Else
If strAppSuffix = "" Then
strShortcutName = "RunPPT " & strPptAppSubfolder & ".lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & " " & strPptAppSubfolder & ".lnk"
End If
End If
' Enable simple error handling.
On Error Resume Next
' Find user's Desktop and AppData\Local folder.
Set objAppShell = CreateObject("Shell.Application")
Set objDesktopFolder = objAppShell.Namespace(DESKTOP)
strDesktopFolder = objDesktopFolder.Self.Path
Set objLocalAppDataFolder = objAppShell.Namespace(LOCALAPPDATA)
strLocalAppDataFolder = objLocalAppDataFolder.Self.Path
' Dynamic parameters.
strLocalAppDataDsgFolder = strLocalAppDataFolder & "\" & strDsgSubfolder
strLocalAppDataDsgPptFolder = strLocalAppDataDsgFolder & "\" & strPptSubfolder
strLocalFolder = strLocalAppDataDsgPptFolder & "\" & strPptAppSubfolder
strAppLocalPath = strLocalFolder & "\" & strAppName
strShortcutLocalPath = strDesktopFolder & "\" & strShortcutName
' Permanent parameters.
strAppRemotePath = strRemoteFolder & "\" & strAppName
strShortcutRemotePath = strRemoteFolder & "\" & strShortcutName
' Create the File System Object.
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(strRemoteFolder) Then
Call ErrorHandler("No access to " & strRemoteFolder & ".")
Else
Set objRemoteFolder = objFSO.GetFolder(strRemoteFolder)
' If local folder does not exist, create the folder.
If Not objFSO.FolderExists(strLocalFolder) Then
If Not objFSO.FolderExists(strLocalAppDataDsgFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalAppDataDsgPPtFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgPptFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgPptFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalFolder & " could not be created.")
End If
End If
End If
Set objLocalFolder = objFSO.GetFolder(strLocalFolder)
End If
If Not objFSO.FileExists(strAppRemotePath) Then
Call ErrorHandler("The application file:" & vbCrLf & strAppRemotePath & vbCrLF & "could not be found.")
Else
' Close a running PPT.
Call KillTask("PPT")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")
Call KillTask("PPT Background")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")
' Copy app to local folder.
If objFSO.FileExists(strAppLocalPath) Then
objFSO.DeleteFile(strAppLocalPath)
If Not Err.Number = 0 Then
Call ErrorHandler("The application file:" & vbCrLf & strAppName & vbCrLF & "can not be refreshed/updated. It may be in use.")
End If
End If
If objFSO.FileExists(strAppLocalPath) Then
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be replaced.")
Else
objFSO.CopyFile strAppRemotePath, strAppLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Application could not be copied to " & strLocalFolder & ".")
End If
' Create copy for PPT Background.
strAppLocalBackPath = Replace(Replace(strAppLocalPath, ".accdb", ".accbg"), "SalesPlanningTool", "SalesPlanningToolBack")
objFSO.CopyFile strAppLocalPath, strAppLocalBackPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Background application could not be copied to " & strLocalFolder & ".")
End If
End If
' Copy shortcut.
objFSO.CopyFile strShortcutRemotePath, strShortcutLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Shortcut could not be copied to your Desktop.")
End If
End If
' Write Registry entries for Access security.
strRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Access\Security\"
strRegValue = "VBAWarnings"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue,"REG_DWORD")
strRegKey = strRegKey & "Trusted Locations\LocationLocalAppData\"
strRegValue = "AllowSubfolders"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue, "REG_DWORD")
strRegValue = "Date"
strRegPath = strRegKey & strRegValue
varValue = Now
varValue = FormatDateTime(varValue, vbShortDate) & " " & FormatDateTime(varValue, vbShortTime)
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
strRegValue = "Description"
strRegPath = strRegKey & strRegValue
varValue = "Local AppData"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
strRegValue = "Path"
strRegPath = strRegKey & strRegValue
varValue = strLocalAppDataFolder & "\"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")
' Run PPT.
If objFSO.FileExists(strAppLocalPath) Then
Call RunApp(strAppLocalPath, False)
Else
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be found.")
End If
Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing
WScript.Quit
' Supporting subfunctions
' -----------------------
Sub RunApp(ByVal strFile, ByVal booBackground)
Dim objShell
Dim intWindowStyle
' Open as default foreground application.
intWindowStyle = 1
Set objShell = CreateObject("WScript.Shell")
objShell.Run Chr(34) & strFile & Chr(34), intWindowStyle, False
Set objShell = Nothing
End Sub
Sub KillTask(ByVal strWindowTitle)
Dim objShell
Set objShell = CreateObject("WScript.Shell")
objShell.Run "TaskKill.exe /FI ""WINDOWTITLE eq " & strWindowTitle & """", 7, False
Set objShell = Nothing
End Sub
Sub AwaitProcess(ByVal strProcess)
Dim objSvc
Dim strQuery
Dim colProcess
Dim intCount
Set objSvc = GetObject("winmgmts:root\cimv2")
strQuery = "select * from win32_process where name='" & strProcess & "'"
Do
Set colProcess = objSvc.Execquery(strQuery)
intCount = colProcess.Count
If intCount > 0 Then
WScript.Sleep 300
End If
Loop Until intCount = 0
Set colProcess = Nothing
Set objSvc = Nothing
End Sub
Sub WriteRegistry(ByVal strRegPath, ByVal varValue, ByVal strRegType)
' strRegType should be:
' "REG_SZ" for a string
' "REG_DWORD" for an integer
' "REG_BINARY" for a binary or boolean
' "REG_EXPAND_SZ" for an expandable string
Dim objShell
Set objShell = CreateObject("WScript.Shell")
Call objShell.RegWrite(strRegPath, varValue, strRegType)
Set objShell = Nothing
End Sub
Sub ErrorHandler(Byval strMessage)
Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing
WScript.Echo strMessage
WScript.Quit
End Sub

Data from Access will not copy to Word bookmark

I have data from a query name "GrabInfoOfMostRecent" and I am using it as a source for Word to fill in a document with bookmarks. However, once I get to any non-text data, I get error 438 "Object doesn't support this property or method".
Specifically:
For "MRN"I have tried all variations of .Range.Text/Value/Value2 and cannot get the number MRN to fill into the appropriate Bookmark.
For "Diagnosis1", I get an Error13 "Type Mismatch" but I don't know why. It is defined as "Short Text" just as all previous text entries are.
Anyone with any help, I would be deeply appreciative.
Sub WordAutomation()
On Error GoTo HandleError
' Object variables for Automation stuff
' declare them like so during development
' you need to set a reference to the applications
'Dim objWord As New Word.Application
' declare them like this when development is complete
' references no longer necessary
Dim objWord As Object
' Object variables for database access
Dim db As DAO.Database
Dim rstPatientVisit As DAO.Recordset
Dim rsReportData As DAO.Recordset
Dim rsExclusions As DAO.Recordset
' Scalar variables
Dim strsql As String
Dim strFile As String
Dim conPath As String
Dim wdGoToBookmark As Integer
'find the folder where the database resides
Set db = CurrentDb
Set rsReportData = db.OpenRecordset("GrabInfoOfMostRecent")
strFile = db.Name
conPath = Mid(strFile, 1, Len(strFile) - Len(Dir(strFile)))
'Step through the records one at a time, creating a Word
'document for each.
'Do While Not rsReportData.EOF
'--create new word document
Set objWord = CreateObject("Word.Application")
objWord.Documents.Add conPath & "TunTemplate.dotx"
' Make both Word and the document are visible
objWord.Visible = True
objWord.Windows(1).Visible = True
'find bookmarks and insert values
With objWord.ActiveDocument.Bookmarks
.Item("RDFirst").Range.Text = rsReportData!RDFirstName
.Item("RDLast").Range.Text = rsReportData!RDLastName
.Item("PFirstName").Range.Text = rsReportData!PVFirstName
.Item("PLastName").Range.Text = rsReportData!PVLastName
.Item("MRN").Range.Value2 = rsReportData!MRN
.Item("RDAddress").Range.Text = rsReportData!RDAddress
.Item("PAddress").Range.Text = rsReportData!Address
.Item("RDCity").Range.Text = rsReportData!RDCity
.Item("RDCounty").Range.Text = rsReportData!RDCounty
.Item("PCity").Range.Text = rsReportData!City
.Item("PCounty").Range.Text = rsReportData!County
.Item("RDPostalCode").Range.Text = rsReportData!RDPostalCode
.Item("PPostalCode").Range.Text = rsReportData!PostalCode
.Item("Diagnosis1").Range.Text = rsReportData!Diagnosis1
.Item("Treatment1").Range.Text = rsReportData!Treatment1
.Item("Changes1").Range.Text = rsReportData!Changes1
.Item("Diagnosis2").Range.Text = rsReportData!Diagnosis2
.Item("Treatment2").Range.Text = rsReportData!Treatment2
.Item("Changes2").Range.Text = rsReportData!Changes2
.Item("Diagnosis3").Range.Text = rsReportData!Diagnosis3
.Item("Treatment3").Range.Text = rsReportData!Treatment3
.Item("Changes3").Range.Text = rsReportData!Changes3
.Item("Diagnosis4").Range.Text = rsReportData!Diagnosis4
.Item("Treatment4").Range.Text = rsReportData!Treatment4
.Item("Changes4").Range.Text = rsReportData!Changes4
.Item("Diagnosis5").Range.Text = rsReportData!Diagnosis5
.Item("Treatment5").Range.Text = rsReportData!Treatment5
.Item("Changes5").Range.Text = rsReportData!Changes5
.Item("Weight").Range.Text = rsReportData!Weight
.Item("Height").Range.Text = rsReportData!Height
.Item("BMICalc").Range.Text = rsReportData!BMICalc
.Item("Waist").Range.Text = rsReportData!Waist
.Item("BP").Range.Text = rsReportData!BP
.Item("RAcuity").Range.Text = rsReportData!REyeAcuity
.Item("LAcuity").Range.Text = rsReportData!LEyeAcuity
.Item("RRetina").Range.Text = rsReportData!RLensRetina
.Item("LRetina").Range.Text = rsReportData!LLensRetina
.Item("HbA1c").Range.Text = rsReportData!HbA1C
.Item("Creatinine").Range.Text = rsReportData!Creatinine
.Item("TChol").Range.Text = rsReportData!TChol
.Item("UrineACR").Range.Text = rsReportData!UrineACR
.Item("LDL").Range.Text = rsReportData!LDL
.Item("TSH").Range.Text = rsReportData!TSH
.Item("HDL").Range.Text = rsReportData!HDL
.Item("B12").Range.Text = rsReportData!B12
.Item("TG").Range.Text = rsReportData!TG
.Item("EGFR").Range.Text = rsReportData!EGFR
End With
'find and write exclusion data
strsql = "SELECT ReportID, Exclusion " & _
"FROM ExclusionData " & _
"WHERE ReportID=" & rsReportData!ReportID
Set rsExclusions = db.OpenRecordset(strsql)
Do While Not rsExclusions.EOF
With objWord.ActiveDocument.Bookmarks
.Item("exclusions").Range.Text = rsExclusions!Exclusion & vbCrLf
rsExclusions.MoveNext
End With
Loop
rsExclusions.Close
'Save the document and close Word
objWord.ActiveDocument.SaveAs (conPath & rsReportData!MRN & ".doc")
'objWord.Quit
'go to next record for processing
'rsReportData.MoveNext
'Loop
'Tell the user the process is done.
MsgBox "Done!" & vbCrLf & vbCrLf & _
"Look in this directory" & vbCrLf & conPath & vbCrLf & _
"for your documents."
ProcDone:
' clean up our object variables
Set objWord = Nothing
Set rsReportData = Nothing
Set rsExclusions = Nothing
Set db = Nothing
ExitHere:
Exit Sub
HandleError:
'display appropriate error message
Select Case Err.Number
Case 5151 'Word template not found
'Close stranded applications
MsgBox "Word template not found"
Case 5152 'Invalid file name
'Close stranded applications
objWord.ActiveDocument.Close SaveChanges:=False
objWord.Quit
MsgBox "This file or folder does not exist"
Case Else
MsgBox Err.Description, vbExclamation, _
"Error " & Err.Number
End Select
Resume ProcDone
End Sub
Simply with the desire to help you troubleshoot this; I offer the following.
Try converting the problem field into a string using:
.Item("Diagnosis1").Range.Text = CStr(rsReportData!Diagnosis1)
You may also want to display a dialog box with the contents of rsReportData!Diagnosis1:
MsgBox "rsReportData!Diagnosis1 is: " & rsReportData!Diagnosis1 _
, vbOkOnly + vbInformation
To convert null values into zero-length-strings, you can use the following:
.Item("Diagnosis1").Range.Text= IIf(IsNull(rsReportData!Diagnosis1), "", rsReportData!Diagnosis1)

VBA DoCmd.OutputTo With QueryDef

I've been looking a while now for a solution to export a query with open parameters. I need to export a Query as a Formatted Excel Spreadsheet and can't create additional Tables, Queries, Forms, or Reports to the Database being used. I use DoCmd.OutputTo as it exports a formatted query unlike DoCmd.TransferSpreadsheet however I can't seem to export the query with defined parameters. I need to include the parameters or else the user will be forced to input the start and end date three times a piece as the database for some reason asks for the startDate and endDate twice and in order to keep the excel spreadsheet and the subsequent outlook section consistant i would have to ask the user to input their previous parameters again
Sub Main()
On Error GoTo Main_Err
'Visually Display Process
DoCmd.Hourglass True
Dim fpath As String
Dim tname As String
Dim cname As String
Dim tType As AcOutputObjectType
Dim tempB As Boolean
fpath = CurrentProject.path & "\"
'tType = acOutputTable
'tname = "APPROVED SWPS FOR LOOK AHEAD & BAR CHART"
tType = acOutputQuery
tname = "ASFLA&BC Query"
cname = "Temp BPC Calendar"
Dim qdfQry As DAO.QueryDef
Dim strStart As String
Dim strEnd As String
Set qdfQry = CurrentDb().QueryDefs(tname)
'strStart = InputBox("Please enter Start date (mm/dd/yyyy)")
'strEnd = InputBox("Please enter Start date (mm/dd/yyyy)")
qdfQry.Parameters("ENTER START DATE") = FormatDateTime("6/30/12", vbShortDate) 'strEnd
qdfQry.Parameters("ENTER END DATE") = FormatDateTime("7/1/12", vbShortDate) 'strStart
tempB = Backup(fpath, qdfQry, tType)
If (Not tempB) Then
MsgBox "Excel Conversion Ended Prematurely..."
Exit Sub
End If
' tempB = sendToOutlook(qdfQry, cname)
' If (Not tempB) Then
' MsgBox "Access Conversion Ended Prematurely..."
' Exit Sub
' End If
MsgBox "Procedure Completed Successfully"
Main_Exit:
DoCmd.Hourglass False
Exit Sub
Main_Err:
DoCmd.Beep
MsgBox Error$
Resume Main_Exit
End Sub
'************************************************************************************
'*
'* Excel PORTION
'*
'************************************************************************************
Public Function Backup(path As String, db As DAO.QueryDef, Optional outputType As AcOutputObjectType) As Boolean
On Error GoTo Error_Handler
Backup = False
Dim outputFileName As String
Dim name As String
Dim tempB As Boolean
'Set Up All Name Variablesand
name = Format(Date, "MM-dd-yy") & ".xls"
'Cleans Directory of Any older files and places them in an archive
SearchDirectory path, "??-??-??.xls", name
'See If File Can Now Be Exported. If Already Exists ask to overwrite
outputFileName = path & name
tempB = OverWriteRequest(outputFileName)
If tempB Then
'Formats The Table And Exports Into A Formatted SpreadSheet
'Checks if an output type was added to the parameter if not defualt to table
If Not IsMissing(outputType) Then
DoCmd.OutputTo outputType, db.name, acFormatXLS, outputFileName, False
Else
DoCmd.OutputTo acOutputTable, db.name, acFormatXLS, outputFileName, False
End If
Else
Exit Function
End If
Backup = True
Error_Handler_Exit:
Exit Function
Error_Handler:
MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
Err.number & vbCrLf & "Error Source: Main Excel Backup" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
The SQL currently given looks like similar to below with omitted fields for for clarity
PARAMETERS [ENTER START DATE] DateTime, [ENTER END DATE] DateTime;
SELECT [SWPS].STATION,
[SWPS].START_DATE,
[SWPS].END_DATE,
FROM [SWPS]
WHERE ((([SWPS].STATION)
Like ("*"))
AND (([SWPS].START_DATE)<=[ENTER END DATE])
AND (([SWPS].END_DATE)>=[ENTER START DATE])
AND (([SWPS].SWP_STATUS) In ("A","P","W","T","R")));
I suggest you change the sql of the query.
Dim qdfQry As DAO.QueryDef
Dim strStart As String
Dim strEnd As String
''You could use a query specifically for this
Set qdfQry = CurrentDb.QueryDefs(tname)
sSQL=qdfQry.SQL
NewSQL = "SELECT [SWPS].STATION, [SWPS].START_DATE, [SWPS].END_DATE, " _
& "FROM [SWPS] WHERE [SWPS].STATION Like '*' " _
& "AND [SWPS].SWP_STATUS In ('A','P','W','T','R') " _
& "AND [SWPS].START_DATE)<=#" & Format(DateStart, "yyyy/mm/dd") & "# " _
& "AND [SWPS].END_DATE)>=#" & Format(DateEnd, "yyyy/mm/dd") & "#"
qdfQry.SQL = NewSQL
''Do the excel stuff
''Reset the query
qdfQry.SQL = sSQL