I have the code below that should let me retrieve the meetings from a shared sub calendar, but it doesn't work.
If I only try to access the main shared calendar it works perfect, but not for the sub calendars..
could someone point me to the right way?
Public Sub getCalendarData(calendar_name As String, sDate As Date, eDate As Date, Optional recurItem As Boolean = True)
On Error GoTo ErrorHandler
Dim oOL As Outlook.Application
Dim oNS As Outlook.Folder
Dim oAppointments As Outlook.AppointmentItem
Dim oAppointmentItem As Outlook.AppointmentItem
Dim strFilter As String
Dim ItemsCal As Outlook.Items
Dim olFolder As Outlook.Folder
Dim fldCalendar As Outlook.Folder
Dim iCalendar As Integer
Dim nmsNameSpace As Outlook.Namespace
Dim objDummy As Outlook.MailItem
Dim objRecip As Outlook.Recipient
'Set objects
Set oOL = CreateObject("Outlook.Application")
Set nmsNameSpace = oOL.GetNamespace("MAPI")
Set objDummy = oOL.CreateItem(olMailItem)
Set objRecip = nmsNameSpace.CreateRecipient("shared calendar name")
objRecip.Resolve
'Set filter to grab items by date range
strFilter = "[Start] >= " _
& "'" & sDate & "'" _
& " AND [End] <= " _
& "'" & eDate & "'"
With ItemsCal
.Sort "[Start]"
.IncludeRecurrences = recurItem
End With
If objRecip.Resolved Then
On Error Resume Next
Set fldCalendar = nmsNameSpace.GetSharedDefaultFolder(objRecip, olFolderCalendar).Folders("sub_calendar_name")
If Not fldCalendar Is Nothing Then
Set ItemsCal = fldCalendar.Items
If Not ItemsCal Is Nothing Then
For Each oAppointmentItem In ItemsCal.Restrict(strFilter)
Set objItem = oAppointmentItem
With oAppointmentItem
iCalendar = getSegmentIDByName(calendar_name)
meeting_id = insertAppointment(iCalendar, .Start, .End, scrubData(.Subject), scrubData(.Location), Format(.Start, "Long Time"), .duration, .Body)
Call GetAttendeeList(meeting_id, objItem, .Recipients)
End With
Next
End If
End If
End If
'Garbage cleanup
Set oAppointmentItem = Nothing
Set oAppoinments = Nothing
Set oNS = Nothing
Set oOL = Nothing
Exit Sub
ErrorHandler:
'MsgBox "Error: " & Err & " | " & Error(Err)
'Whenever error occurs, skip to next
Resume Next
End Sub
The problem is that fldCalendar is always returning nothing and I don't know what is wrong..
Thank you!
Keep in mind that in the cached mode when you are accessing a default folder from another mailbox, you are not accessing the whole mailbox - the folder (but not its subfolders) is cached in your primary OST file.
You can add the whole mailbox as a delegate store (Advanced tab of the Exchange account properties dialog box) and then drill down to that folder from Store.RootFolder (where Store is retrieved from the Namespace.Stores collection).
If using Redemption is an option (I am its author), its version of RDOSession.GetSharedDefaultFolder (or RDOSession.GetSharedMailbox) returns a live folder (RDOFolder), not its cached version, so you will be able to access the subfolders.
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 have an access macro that runs a set of Netezza queries and uploads the results to a database. It then opens and refreshes an Excel file that utilizes this data and saves the file in a couple of locations. Finally it composes an automated email and sends it to a distribution list. When I manually run the macro, everything works 100% perfectly.
In order to make my life a bit easier, I am using Windows Task Scheduler (Windows 10) to automatically fire the macro once a day, and this is where my issue lies. Task Scheduler fires the macro off without a hitch, all of the queries refresh, the excel files are saved, but the e-mail is not sent.
Here is the code SendOutlookEmail code that I'm using
Sub sendOutlookEmail()
Dim oApp As Outlook.Application
Dim oMail As MailItem
Dim SpDate As String
Dim Signature As String
Dim StrPath As String
Dim StrFilter As String
Dim StrFile As String
SpDate = Format(Now() - 1, "yyyy-mm-dd")
Set oApp = CreateObject("Outlook.application")
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.Display
End With
Signature = oMail.HTMLBody
With oMail
.SentOnBehalfOfName = "My Email"
.To = "CCO Reporting"
.Subject = "AHT - ACW Dashboard - " & SpDate
.HTMLBody = "<span LANG=EN>" _
& "<font FACE=SegoeUI SIZE = 3>" _
& "The IB/OB AHT - ACW reports have been updated and placed in the following folder:" _
& "<br><br>" _
& "<a href='File Location'>File Location</a>" & "<br><br><br></font></span>" _
& Signature
'.Attachments.Add (StrPath & StrFile)
'.Display
.Send
End With
On Error GoTo 0
Set oMail = Nothing
Set oApp = Nothing
End Sub
Here is the task scheduler settings
Task Scheduler
Possibly Outlook just doesn't have enough time to send the message, as it instantly gets closed after the message is moved to the outbox (.send doesn't send the message as far as I know, but just moves it to the outbox and triggers a send for all items in there).
Try to manually add a send/receive, to make Access wait for Outlook to actually send the mails (add this to your vba before the Set oApp = Nothing):
' Synchronizes (ie sends/receives) OL folders.
' Ref: http://msdn.microsoft.com/en-us/library/ff863925.aspx
Dim objNsp As Outlook.NameSpace
Dim colSyc As Outlook.SyncObjects
Dim objSyc As Outlook.SyncObject
Dim i As Integer
On Error GoTo SyncOL_Err
Set objNsp = oApp.Application.GetNamespace("MAPI")
Set colSyc = objNsp.SyncObjects
For i = 1 To colSyc.Count
Set objSyc = colSyc.Item(i)
Debug.Print objSyc.Name
objSyc.start
Next
Set objNsp = Nothing: Set colSyc = Nothing: Set objSyc = Nothing
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
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
I have an access report that updates 4 image controls based on a table that is sourcing images from a directory. The report generates a page per record, however the image controls are not changing after page 1 (just showing same images for all the other pages). Appartently, the code worked fine on Windows XP and now does not work on Windows 7 OS (both used Office 07). Here is the code:
Private Sub Report_Current()
UpdateImages
End Sub
Private Sub Report_Load()
UpdateImages
End Sub
Private Sub Report_Page()
UpdateImages
End Sub
Private Sub UpdateImages()
On Error GoTo errHandler
Dim RS As DAO.Recordset
Set RS = CurrentDb.OpenRecordset("SELECT Image_Loc, Image_Name FROM HH_Media WHERE InspectionID = " & CInt(Me.InspectionID.Value) & " ORDER BY MediaID ASC")
If Not RS.BOF And Not RS.EOF Then
Dim i As Integer
For i = 1 To 4
If Not RS.EOF Then
Dim pictureCtrl As Image
Set pictureCtrl = GetControl("Image" & i)
Dim strImage As String
strImage = RS.Fields("Image_Loc").Value & "\" & RS.Fields("Image_Name").Value
If Not pictureCtrl Is Nothing Then
If FileExists(strImage) Then
pictureCtrl.Picture = strImage
SetLabel "lblImage" & i, RS.Fields("Image_Name").Value
Else
pictureCtrl.Picture = ""
SetLabel "lblImage" & i, "Does not exist"
End If
End If
RS.MoveNext
Else
Exit For
End If
Next
End If
RS.Close
Set RS = Nothing
Exit Sub
errHandler:
MsgBox "An error occurred while updating the form display." & vbNewLine & Err.Description, vbApplicationModal + vbCritical + vbDefaultButton1 + vbOKOnly, Me.Name
Resume Next
End Sub
The images do exist in the directory that are referenced in the table. Any ideas of what is missing?
Thank You
Whenever I need to do some dynamic content I always use the [section]_Format event - so if your controls are on the Detail section then:
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
If FormatCount = 1 then 'only need to do this once per record
UpdateImages
Endif
End Sub
I've never seen the GetControl method, and I don't have a lot of experience using the Image control, but it seems like that the Dim statement should read more like:
Dim pictureCtrl as Control
Set pictureCtrl = Me.Controls("Image" & i)
I would insert a break and verify that
strImage = RS.Fields("Image_Loc").Value & "\" & RS.Fields("Image_Name").Value
is returning values you expect. You can also shorten these to:
strImage = rs!Image_Loc & "\" & rs!Image_Name
sometimes Access doesn't like the added ".value" as this is already the default return.