I'm using Exchanged Web Services and would like to retrieve a users "Work Hours". Work hours is a setting on the Calendar and helps with free/busy calculations, but I'd like to get or calculate the actual values.
I have full access to the calendar. If I can use the EWS Managed API that would be my preference. I've searched online, and looked at the GetUserAvailability operation, but I haven't been able to find a method that will give me this data.
If your using Exchange 2010 or later you can get the working hours configuration (documented in http://msdn.microsoft.com/en-us/library/ee202895(v=exchg.80).aspx ) from the IPM.Configuration.WorkHours UserConfiguration FAI object (Folder Associated Items) using the GetUserConfiguration operation in EWS http://msdn.microsoft.com/en-us/library/office/dd899439(v=exchg.150).aspx . eg
UserConfiguration usrConfig = UserConfiguration.Bind(service, "WorkHours", WellKnownFolderName.Calendar, UserConfigurationProperties.All);
XmlDocument xmlDoc = new XmlDocument();
xmlDoc.Load(new MemoryStream(usrConfig.XmlData));
XmlNodeList nlList = xmlDoc.GetElementsByTagName("WorkHoursVersion1");
Console.WriteLine(nlList.Item(0).InnerXml);
I thought I would update this for VBA, I know it is an old thread but may help people and save them some time. I wrote the following for use in Excel to get to Outlook Calendar settings. I would welcome any feedback and tips on better/neater code writing.
Function GetUserWorkingHours(WHType As String, oCalendarFolder As Object) As String
' Returns user's Calendar Start or End work times
' Uses existing Outlook calendar folder object
' The workinghours data is stored in a hidden Outlook storage binary stream in xml format (no, seriously, it is!)
' ... with a sign on the door saying "beware of the leopard"
'
' Cheshire Catalyst software July 2020
'
Dim olStorage As Object
Dim olPropacc As Object
Dim olBytes() As Byte
Dim a As Variant
Dim xmlString As String ' xml stream text stored here
Dim objDOM As Object ' xml object to parse the xml stream
Dim Result As String ' Holding place for return value
' Loads the hidden Outlook xml store to retrieve WorkingHours
Set olStorage = oCalendarFolder.GetStorage("IPM.Configuration.workhours", 2)
Set olPropacc = olStorage.PropertyAccessor
olBytes = olPropacc.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7C080102")
' Translate binary stream into text byte by byte (there may be a better way to do this but this way works)
For Each a In olBytes
xmlString = xmlString & Chr(a)
Next a
' Generate the xml object to parse
Set objDOM = CreateObject("Msxml2.DOMDocument.3.0")
' Load the xml stream into the xml parser
objDOM.LoadXML xmlString
' Filter on what we are looking for
Select Case WHType
Case "Start"
Result = objDOM.SelectSingleNode("Root/WorkHoursVersion1/TimeSlot/Start").Text
Case "End"
Result = objDOM.SelectSingleNode("Root/WorkHoursVersion1/TimeSlot/End").Text
Case Else
' Perhaps we should have tested for this before all that messing about with Outlook stores
Result = "Invalid" ' Invalid request
End Select
GetUserWorkingHours = Result
' Tidy up all those objects
Set olStorage = Nothing
Set olPropacc = Nothing
Set objDOM = Nothing
Erase olBytes
End Function
Sub testit()
Dim oOutlook As Object ' Outlook instance
Dim oNS As Object ' Outlook namespace
Dim oCalendar As Object ' Calendar folder of Outlook instance
Set oOutlook = GetObject(, "Outlook.Application")
Set oNS = oOutlook.GetNamespace("MAPI")
Set oCalendar = oNS.GetDefaultFolder(9)
MsgBox ("Start: " & GetUserWorkingHours("Start", oCalendar) & " End: " & GetUserWorkingHours("End", oCalendar))
End Sub
Related
I have a word document that uses mail merge feature and gets its information from the access db. When I use this code it does not open the word document with the current information. It opens the word document with the last saved information.
If I open the word document on its own, from the task bar, it asks if I want to run the SQL and I click yes and everything operates normally. I want to click a button from within access to accomplish this same task to open the contract.
Here is the code I used:
Private Sub Command205_Click()
Dim LWordDoc As String
Dim oApp As Object
'Path to the word document
LWordDoc = "C:\Users\.....k Up\01- Proposal\contract.docx"
If Dir(LWordDoc) = "" Then
MsgBox "Document not found."
Else
'Create an instance of MS Word
Set oApp = CreateObject(Class:="Word.Application")
oApp.Visible = True
'Open the Document
oApp.Documents.Open FileName:=LWordDoc
End If
End Sub
***I should add that I am not a coder and know nothing about VBA, I copied this from this website so any help you can offer would be greatly appreciated. If you can provide me with coding or enough guidance to get me on the way would be great. Thank you
This code will run in Access to open a Mail Merge document and update content and save.
Using the link I originally posted (http://www.minnesotaithub.com/2015/11/automatic-mail-merge-with-vba-and-access/), I made a couple of modifications and was able to get that code to work.
I needed to add: ReadOnly:=True, _ to prevent a sharing violation
and I changed the Table Name of the source data.
NOTE!! You will need to change sode marked with'###' as follows:
###-1 Change to specify the full path of your TEMPLATE!!!
###-2 Change the SQLSTATEMENT to specify your recordsource!!!
Paste this code into your form, make sure you have a Command Button Click Event that executes (Either rename 'Command205' in this code, or change your control name).
Option Compare Database
Option Explicit
Private Sub Command205_Click()
Dim strWordDoc As String
'Path to the word document of the Mail Merge
'###-1 CHANGE THE FOLLOWING LINE TO POINT TO YOUR DOCUMENT!!
strWordDoc = "C:\Users\.....k Up\01- Proposal\contract.docx"
' Call the code to merge the latest info
startMerge strWordDoc
End Sub
'----------------------------------------------------
' Auto Mail Merge With VBA and Access (Early Binding)
'----------------------------------------------------
' NOTE: To use this code, you must reference
' The Microsoft Word 14.0 (or current version)
' Object Library by clicking menu Tools > References
' Check the box for:
' Microsoft Word 14.0 Object Library in Word 2010
' Microsoft Word 15.0 Object Library in Word 2013
' Click OK
'----------------------------------------------------
Function startMerge(strDocPath As String)
Dim oWord As Word.Application
Dim oWdoc As Word.Document
Dim wdInputName As String
Dim wdOutputName As String
Dim outFileName As String
' Set Template Path
wdInputName = strDocPath ' was CurrentProject.Path & "\mail_merge.docx"
' Create unique save filename with minutes and seconds to prevent overwrite
outFileName = "MailMergeFile_" & Format(Now(), "yyyymmddmms")
' Output File Path w/outFileName
wdOutputName = CurrentProject.Path & "\" & outFileName
Set oWord = New Word.Application
Set oWdoc = oWord.Documents.Open(wdInputName)
' Start mail merge
'###-2 CHANGE THE SQLSTATEMENT AS NEEDED
With oWdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=CurrentProject.FullName, _
ReadOnly:=True, _
AddToRecentFiles:=False, _
LinkToSource:=True, _
Connection:="QUERY mailmerge", _
SQLStatement:="SELECT * FROM [tblEmployee]" ' Change the table name or your query
.Destination = wdSendToNewDocument
.Execute Pause:=False
End With
' Hide Word During Merge
oWord.Visible = False
' Save file as PDF
' Uncomment the line below and comment out
' the line below "Save file as Word Document"
'------------------------------------------------
'oWord.ActiveDocument.SaveAs2 wdOutputName & ".pdf", 17
' Save file as Word Document
' ###-3 IF YOU DON'T WANT TO SAVE AS A NEW NAME, COMMENT OUT NEXT LINE
oWord.ActiveDocument.SaveAs2 wdOutputName & ".docx", 16
' SHOW THE DOCUMENT
oWord.Visible = True
' Close the template file
If oWord.Documents(1).FullName = strDocPath Then
oWord.Documents(1).Close savechanges:=False
ElseIf oWord.Documents(2).FullName = strDocPath Then
oWord.Documents(2).Close savechanges:=False
Else
MsgBox "Well, this should never happen! Only expected two documents to be open"
End If
' Quit Word to Save Memory
'oWord.Quit savechanges:=False
' Clean up memory
'------------------------------------------------
Set oWord = Nothing
Set oWdoc = Nothing
End Function
I have a lotus agent running with lotusscript. Form the browser I post form data to the webserver and I receive this data with the following lotusscript:request_method = doc.GetItemValue( "request_content" )(0)
But if I have a form with for example name and phonenumber. Then my agent receives this as name=bla&phonenumber=243525
How can i separate these fields actually and secondly how can I receive XML on this agent so that I can extract this and put in to a document. I googled a lot but still got no solutions.
The way you get the data differs if the client makes a GET or a POST.
If this is a get, all the parameters are in the url in a url format.
Many many ressource on the web will give you some code to parse this url and get name and value a simple search in goolge will bring : http://searchdomino.techtarget.com/tip/Parsing-URL-Parameters-with-Ease
I use generally the following code, which add in the document context the fields received on url or on post.
Dim s As NotesSession
Set s = New notessession
Set doc = s.documentcontext
Dim myQuerystring As String
If doc Is Nothing Then
logErrorEX "getting a call without document context ?!?","", doc,""
GoTo returnErr
End If
If doc.QUERY_STRING_DECODED(0)<>"" Then'it's a GET
myQuerystring = doc.QUERY_STRING_DECODED(0)
ElseIf doc.QUERY_STRING(0)<>"" Then
myQuerystring = doc.QUERY_STRING(0)
'decode it !
ElseIf doc.REQUEST_CONTENT(0)<>"" Then'it's a POST
myQuerystring = doc.REQUEST_CONTENT(0) ' WARNING this is for POST but you will have to decode !!!
'decode it !
Else
logErrorEX "getting a call with document context but without query_string?!?","", doc,""
GoTo returnErr
End if
Call ExplodeQueryString(myQuerystring, doc)
Private Sub ExplodeQueryString (QueryString As String,doc As NotesDocument )
Dim ArgsList As Variant
ArgsList = Split (QueryString, "&")
If IsArray(ArgsList) Then
debugString = debugString+"ArgsList is an array of " & UBound(ArgsList)
Else
debugString = debugString+"ArgsList is NOT an array ??? " & ArgsList
End if
Dim ArgKey As String
Dim ArgValue As String
ForAll Arg In ArgsList
If left$(Arg, 1)= "_" Or Left$(Arg, 1)= "%" Then
'ignore it
else
ArgKey = strleft(Arg, "=")
If ArgKey = "" Then
'ignore it?
else
ArgValue = strright$(Arg, "=")
' AgentArgs(ArgKey) = ArgValue
doc.Replaceitemvalue ArgKey, ArgValue
End If
End if
End ForAll
End Sub
I didn't declare some global variable like debugString to shorten in.
The format you are seeing is the convention used by all web browser software to encode field data from forms. You can use functions similar to the ExplodeQueryString function in the code posted by Emmanual to parse it. It looks to me like he is taking each "&name" portion and creating a NotesItem with that name and using it to store the value from the "=value" portion. You can do that, or you can use a List, or whatever best fits your requirements.
There is no rule against sending POST data in other formats without using the &name=value convention. It just requires agreement between whatever software is doing the sending and your software on the receiving side. If they want to send you XML in the POST data, that's fine. You can use standard XML parsing functions to deal with it. Notes comes with a NotesDOMParsesr class that you can use if you want. If you are running on Windows, you can use Microsoft.XMLDOM instead.
I wrote a class a while back that does exactly what you ask for. It splits the query string (or request content) into a list of values, with the name as the list tag.
http://blog.texasswede.com/free-code-class-to-read-url-name-value-pairs/
Here is the code (I usually put it in a script library called Class.URL):
%REM
Library Class.URL
Created Oct 9, 2014 by Karl-Henry Martinsson
Description: Lotusscript class to handle incoming URL (GET/POST).
%END REM
Option Public
Option Declare
%REM
Class URLData
Description: Class to handle URL data passed to web agent
%END REM
Class URLData
p_urldata List As String
%REM
Sub New()
Description: Create new instance of URL object from NotesDocument
%END REM
Public Sub New()
Dim session As New NotesSession
Dim webform As NotesDocument
Dim tmp As String
Dim tmparr As Variant
Dim tmparg As Variant
Dim i As Integer
'*** Get document context (in-memory NotesDocument)
Set webform = session.DocumentContext
'*** Get HTTP GET argument(s) after ?OpenAgent
tmp = FullTrim(StrRight(webform.GetItemValue("Query_String")(0),"&"))
If tmp = "" Then
'*** Get HTTP POST argument(s) after ?OpenAgent
tmp = FullTrim(StrRight(webform.GetItemValue("Request_Content")(0),"&"))
End If
'*** Separate name-value pairs from each other into array
tmparr = Split(tmp,"&")
'*** Loop through array, split each name-value/argument
For i = LBound(tmparr) To UBound(tmparr)
tmparg = Split(tmparr(i),"=")
p_urldata(LCase(tmparg(0))) = Decode(tmparg(1))
Next
End Sub
%REM
Function GetValue
Description: Get value for specified argument.
Returns a string containing the value.
%END REM
Public Function GetValue(argname As String) As String
If IsElement(p_urldata(LCase(argname))) Then
GetValue = p_urldata(LCase(argname))
Else
GetValue = ""
End If
End Function
%REM
Function IsValue
Description: Check if specified argument was passed in URL or not.
Returns boolean value (True or False).
%END REM
Public Function IsValue(argname As String) As Boolean
If IsElement(p_urldata(LCase(argname))) Then
IsValue = True
Else
IsValue = False
End If
End Function
'*** Private function for this class
'*** There is no good/complete URL decode function in Lotusscript
Private Function Decode(txt As String) As String
Dim tmp As Variant
Dim tmptxt As String
tmptxt = Replace(txt,"+"," ")
tmp = Evaluate(|#URLDecode("Domino";"| & tmptxt & |")|)
Decode = tmp(0)
End Function
End Class
And this is how you can use it:
Option Public
Option Declare
Use "Class.URL"
Sub Initialize
Dim url As URLData
'*** Create new URLData object
Set url = New URLData()
'*** MIME Header to tell browser what kind of data we will return
Print "content-type: text/html"
'*** Check reqired values for this agent
If url.IsValue("name")=False Then
Print "Missing argument 'name'."
Exit Sub
End If
'*** Process name argument
If url.GetValue("name")="" Then
Print "'Name' is empty."
Else
Print "Hello, " + url.GetValue("name") + "!"
End If
End Sub
I'm writing a query to extract text that was entered through a vendor-created word processor to an Oracle database and I need to export it to Word or Excel. The text is entered into a memo field and the text is intertwined with codes that the word processor uses for different functions (bold, indent, hard return, font size, etc.).
I've used the replace function to parse out a lot of the more common codes, but there are so many variations, it's nearly impossible to catch them all. Is there a way to do this? Unfortunately, I'm limited to using Microsoft Access 2010 to try and accomplish this.
The common thread I've found is that all the codes start with a back-slash and I'd like to be able to delete all strings that start with a back-slash up to the next space so all the codes are stripped out of the final text.
Here's a brief example of the text I'm working with:
{\rtf1\ansi\ansicpg1252\deff0\deflang1033{\fonttbl{\f0\fnil\fcharset0 Times New Roman;
\viewkind4\uc1\pard\f0\fs36 An abbreviated survey was conducted
on 02/02/15 to investigate complaint #OK000227. \par
No deficiencies were cited.\par
\fs20\par
}}
If your machine has Microsoft Word installed then you already have an RTF parser available so you don't have to "roll your own". You can just get Word to open the RTF document and save it as plain text like this:
Option Compare Database
Option Explicit
Public Function RtfToPlainText(rtfText As Variant) As Variant
Dim rtn As Variant
Dim tempFolder As String, rtfPath As String, txtPath As String
Dim fso As Object ' FileSystemObject
Dim f As Object ' TextStream
Dim wordApp As Object ' Word.Application
Dim wordDoc As Object ' Word.Document
Dim tempFileName As String
tempFileName = "~RtfToPlainText"
If IsNull(rtfText) Then
rtn = Null
Else
' save RTF text as file
Set fso = CreateObject("Scripting.FileSystemObject")
tempFolder = fso.GetSpecialFolder(2) ' Temporaryfolder
rtfPath = tempFolder & "\" & tempFileName & ".rtf"
Set f = fso.CreateTextFile(rtfPath)
f.Write rtfText
f.Close
Set f = Nothing
' open in Word and save as plain text
Set wordApp = CreateObject("Word.Application")
Set wordDoc = wordApp.Documents.Open(rtfPath)
txtPath = tempFolder & "\" & tempFileName & ".txt"
wordDoc.SaveAs2 txtPath, 2 ' wdFormatText
wordDoc.Close False
Set wordDoc = Nothing
wordApp.Quit False
Set wordApp = Nothing
fso.DeleteFile rtfPath
' retrieve plain text
Set f = fso.OpenTextFile(txtPath)
rtn = f.ReadAll
f.Close
Set f = Nothing
fso.DeleteFile txtPath
Set fso = Nothing
End If
RtfToPlainText = rtn
End Function
Then, if you had a table with two Memo fields - [rtfText] and [plainText] - you could extract the plain text into the second Memo field using the following query in Access:
UPDATE rtfTestTable SET plainText = RtfToPlainText([rtfText]);
The text you are working with is RTF. Here is a tutorial about the file format.
This link (on another site, registration required) may give you copy & paste code you can use to convert rtf fields to txt.
You may be able to copy the value of the field from the database and paste it into notepad and then save the notepad file as "test.rtf"...you could then double click the file icon and the document may open.
RTF is an old MS file format that allows formatting of text. See this wikipedia page.
I am trying to create a button on my access form that allows for the user to view the corresponding page that goes with the data within the form (In this case, a part number is displayed on the form, and I want the button to open the Part Standard file to show the blueprint/diagram of said part)
I have tried using Adobe's page parameters #page=pagenum at the end of my filepath, but doing this doesn't work.
Here is the code I have (Basic, I know) but I'm trying to figure out where to go here. I have simple condensed down my filepath, for obvious reasons - Note: It's not a URL, but a file path if this matters.
Private Sub Command80_Click()
Dim loc As String 'location of file
'loc = Me.FileLoc
loc = "G:\*\FileName.pdf#page=1"
Debug.Print loc
'Debug.Print Me.FileLoc
'Debug.Print Me.FileName
Application.FollowHyperlink loc
End Sub
Is this possible to do this way? I will continue to read other users posts in hopes to find a solution, and I'll note here if I do find one.
Thanks!
Update
I've found a way to do this, just I have 1 small complication now. My database will be accessed by many users, possibly with different versions of Acrobat, or different locations. Here is my working code:
Private Sub Command2_Click()
pat1 = """C:\Program Files\Adobe\Reader 9.0\Reader\AcroRd32.exe"""
pat2 = "/A ""page=20"""
pat3 = """G:\*\FileName.pdf"""
Shell pat1 & " " & pat2 & " " & pat3, vbNormalFocus
End Sub
Now, here is my concern. This code opens AcroRd32.exe from a specific file path, if my users have this stored elsewhere or have a different version, this won't work. Does anyone have a suggestion as how to possibly get around this?
Thanks again! :)
The correct way to do this is probably to look up the location of the acrobat reader executable in the system registry. I find that's generally more trouble than it's worth, especially if I have some control over all of the places my program will be installed (within a single intranet, for example). Usually I end up using this function that I wrote:
'---------------------------------------------------------------------------------------
' Procedure : FirstValidPath
' Author : Mike
' Date : 5/23/2008
' Purpose : Returns the first valid path found in a list of potential paths.
' Usage : Useful for locating files or folders that may be in different locations
' on different users' computers.
' Notes - Directories must be passed with a trailing "\" otherwise the function
' will assume it is looking for a file with no extension.
' - Returns Null if no valid path is found.
' 5/6/11 : Accept Null parameters. If all parameters are Null, Null is returned.
'---------------------------------------------------------------------------------------
'
Function FirstValidPath(ParamArray Paths() As Variant) As Variant
Dim i As Integer
FirstValidPath = Null
If UBound(Paths) - LBound(Paths) >= 0 Then
For i = LBound(Paths) To UBound(Paths)
If Not IsNull(Paths(i)) Then
If Len(Dir(Paths(i))) > 0 Then
FirstValidPath = Paths(i)
Exit For
End If
End If
Next i
End If
End Function
The function takes a parameter array so you can pass it as many or as few paths as necessary:
PathToUse = FirstValidPath("C:\Program Files\Adobe\Reader 9.0\Reader\AcroRd32.exe", _
"C:\Program Files\Acrobat\Reader.exe", _
"C:\Program Files (x86)\Acrobat\Reader.exe", _
"C:\Program Files\Acrobat\12\Reader.exe")
pat1 = """" & PathToUse & """"
Registry keys are the better way to go, unlike file locations they have consistency between systems.
Below are three functions, two in support of one, and a macro which tests the functions.
GetARE() (Get Adobe Reader Executable) returns the proper path based on a version search in a pre-defined location passed as the argument. This removes the hassle of typing out many different key locations for each version and provides some amount of coverage should future versions be released and installed on a user's system.
I have installed previous versions of Reader to test whether or not the there is consistency in the InstallPath key location, up until quite outdated versions, there is. In fact, mwolfe02 and I both have our keys in the same location, though I am using version 11 and he, at the time of writing, was using 10. I was only able to test this on a x64 system, but you can easily modify the code below to search for both x64 and x86 keys. I expect a large corporation like Adobe to stick to their conventions, so this will likely work for quite some time without much modification even as new versions of Reader are released.
I wrote this quickly, expect inefficiency and inconsistency in naming conventions.
Truly the best approach to ensure the path is almost-always returned would be to simply run a registry search through VBA in a loop for version numbers using "*/Acrobat Reader/XX.YY/InstallPath/" and then including the executable based on a check for the appropriate candidate in the appropriate directory; however, this isn't exactly a very cost-effective solution. My tests have shown that there is quite a bit of consistency between versions as to where the Install Path can be found, and as to what the executable name may be, so I opted for something more efficient if less lasting.
RegKeyRead() and RegKeyExists() were taken from:
http://vba-corner.livejournal.com/3054.html
I have not modified their code. Take into consideration saying thanks to the author of that post, the code is not complex by any means but it did save me the hassle of writing it myself.
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object
On Error Resume Next
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'read key from registry
RegKeyRead = myWS.RegRead(i_RegKey)
End Function
Function RegKeyExists(i_RegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set myWS = CreateObject("WScript.Shell")
'try to read the registry key
myWS.RegRead i_RegKey
'key was found
RegKeyExists = True
Exit Function
ErrorHandler:
'key was not found
RegKeyExists = False
End Function
Function GetARE(i_RegKey As String) As String
Dim InPath As String
Dim InKey As String
Dim Ind As Integer
Dim PriVer As String
Dim SubVer As String
Dim Exists As Boolean
Exists = False
PriVer = 1
SubVer = 0
For Ind = 1 To 1000
If SubVer > 9 Then
PriVer = PriVer + 1
SubVer = 0
End If
Exists = RegKeyExists(i_RegKey + "\" + PriVer + "." + SubVer + "\InstallPath\")
SubVer = SubVer + 1
If Exists = True Then
SubVer = SubVer - 1
InKey = i_RegKey + "\" + PriVer + "." + SubVer + "\InstallPath\"
InPath = RegKeyRead(InKey)
GetARE = InPath + "\AcroRd32.exe"
Exit For
End If
Next
End Function
Sub test()
Dim rando As String
rando = GetARIP("HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Adobe\Acrobat Reader")
MsgBox (rando)
End Sub
I remember that Acrobat reader used to include some ActiveX PDF reader object available for further use with Microsoft Office. Other companies have developed similar products, some of them (in their basic form) even available for free.
That could be a solution, couldn't it? You'd have then to check that your activeX PDF reader supports direct page access in its methods, and distribute it with your apps, or have it installed on your user's computers. It will avoid you all the overhead related to acrobat readers versions follow-up, specially when newer versions will be available on the market and you'll have to update your client interface.
Just to add to mwolfe02's answer, here is a function that tries to retrieve the executable for the file type given (it also uses the registry commands Levy referenced) :
Function GetShellFileCommand(FileType As String, Optional Command As String)
Const KEY_ROOT As String = "HKEY_CLASSES_ROOT\"
Dim sKey As String, sProgramClass As String
' All File Extensions should start with a "."
If Left(FileType, 1) <> "." Then FileType = "." & FileType
' Check if the File Extension Key exists and Read the default string value
sKey = KEY_ROOT & FileType & "\"
If RegKeyExists(sKey) Then
sProgramClass = RegKeyRead(sKey)
sKey = KEY_ROOT & sProgramClass & "\shell\"
If RegKeyExists(sKey) Then
' If no command was passed, check the "shell" default string value, for a default command
If Command = vbNullString Then Command = RegKeyRead(sKey)
' If no Default command was found, default to "Open"
If Command = vbNullString Then Command = "Open"
' Check for the command
If RegKeyExists(sKey & Command & "\command\") Then GetShellFileCommand = RegKeyRead(sKey & Command & "\command\")
End If
End If
End Function
so,
Debug.Print GetShellFileEx("PDF")
outputs:
"C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe" "%1"
and you just have to replace the "%1" with the file you want to open and add any parameters you need.
Here is code the probably you can use..
Private Sub CommandButton3_Click()
Dim strFile As String
R = 0
If TextBox7 = "CL" Then
R = 2
' Path and filename of PDF file
strFile = "E:\Users\Test\Cupertino Current system.pdf"
ActiveWorkbook.FollowHyperlink strFile
End If
if R = 0 Then
MsgBox "Wrong Code"
ComboBox1 = ""
TextBox1 = Empty
'ComboBox1.SetFocus
End If
End Sub
Just need to the right path.. Hope this can help you
I need to make a "static html" FAQ-like-document for internal use on a project.
I put all the items in an Access 2007 Database as records (question, answer, category) and then built a report that uses a sub-report to create a table of contents as internal links and then lists all of the questions and answers. This report is a bunch of text-areas with dynamically generated html code(apparently I don't have enough cred to post images yet so http://i115.photobucket.com/albums/n299/SinbadEV/ReportCapture.png)... I just export the report to a text file and then rename it to .html and open it in a browser.
I'm thinking there has to be a less evil way to do this.
I have now used an idea from SinbadEV and awrigley to create professionally looking HTML-reports in MS Access 2007. In my case I had to use yet another trick:
I found out, that due to some bug in MS Access it does not save the report correctly to txt format. Sometimes it drops a lot of information, even though it is displayed on the screen. I have also seen problem, mentioned here that sometimes access mixing lines. It seem to depend on several factors, e.g. whether report and a data span across pages in MS Acess report.
However I found, that exporting to *.rtf does work correctly. Therefore the approach is to craft MS Acess report, which, when saved into text file would create an HTML code (just like described by SinbadEV ), however you 1st need to save it to *rtf. After that you need to use MS Word automation to convert from *.rtf to txt file and to give it .html extention (In reality it does not take too much efforts).
Instead of MS word automation one can probably also use tool like Doxillion Document Converter to convert from rtf to text format from command line.
You can see database with this feature in the Meeting minutes, Issues, Risks, Agreements, Actions, Projects Tracking tool (http://sourceforge.net/projects/miraapt/).
There's an ExportXML method in the Application object, which can export database objects (tables,reports etc.) in XML. You'll need a XSL style sheet or a XSTL document if you want to format it for a browser:
http://msdn.microsoft.com/en-us/library/bb258194(v=office.12).aspx
I'd say this is the "canonical" way to do it. OTOH writing XSL & XSTL isn't like a fun thing to do and if you HTML generator works, then you should simply keep it like it is. (Actually, it's a nice trick IMHO).
I don't see anything inherently "evil" in what you are doing. I wrote an article for (the now defunct magazine) Smart Access that uses a similar technique for a different reason. The HTML report was a by product. Essentially, my technique allows using Access to create very extensive word documents that flow like typed text rather than looking like reports created using boxes.
You can still read the article on MSDN:
Extending Access Reports With Word and HTML
The trick was to generate HTML using a report like you are doing, then using automation, open the .html file in Word and save it as RTF.
We used the technique to create a 300 page directory for the Diocese of York. It worked flawlessly.
Just in case you want to go the VBA way: I wrote a few functions that can make it quite easy:
create queries containing the data you want to output,
then open the query and loop through all records, outputting data to text file using function rRsToXml below.
Option Compare Database
Option Explicit
Function fRsToXml(rs As Recordset, Optional ignorePrefix As String = "zz", _
Optional ignoreNulls As Boolean = False) As String
'<description> Returns an XML string with all fields of the current record,
' using field names as tags.
' Field names starting with "zz" (or other special prefix) are ignored</description>
'<parameters> rs: recordset (byRef, of course)</parameters>
'<author> Patrick Honorez - www.idevlop.com </author>
Dim f As Field, bPrefLen As Byte
Dim strResult As String
bPrefLen = Len(ignorePrefix)
For Each f In rs.Fields
If Left(f.Name, bPrefLen) <> ignorePrefix Then 'zz fields are ignored !
If (Not ignoreNulls) Or (ignoreNulls And Not IsNull(f.Value)) Then
strResult = strResult & xTag(f.Name, f.Value) & vbCrLf
End If
End If
Next f
fRsToXml = strResult
End Function
Function xTag(ByVal sTagName As String, ByVal sValue, Optional SplitLines As Boolean = False) As String
'<description> Create an xml node and returns it as a string </description>
'<parameters> <sTagName> name of the tag </sTagName>
' <sValue> string to embed </sValue>
' <SplitLine> True to include CrLf at the end of each line
' (optional - default = False) </SplitLine></parameters>
'<author> Patrick Honorez - www.idevlop.com </author>
'<note> Make sure sValue does not contains XML forbidden characters ! </note>
'<changelog>
'</changelog>
Dim strNl As String, intAmp
If SplitLines Then
strNl = vbCrLf
Else
strNl = vbNullString
End If
xTag = "<" & sTagName & ">" & strNl & _
Nz(sValue, "") & strNl & _
"</" & sTagName & ">" '& strNl
End Function
Function CleanupStr(strXmlValue) As String
'<description> Replace forbidden char. &'"<> by their Predefined General Entities </description>
'<author> Patrick Honorez - www.idevlop.com </author>
Dim sValue As String
If IsNull(strXmlValue) Then
CleanupStr = ""
Else
sValue = CStr(strXmlValue)
sValue = Replace(sValue, "&", "&") 'do ampersand first !
sValue = Replace(sValue, "'", "'")
sValue = Replace(sValue, """", """)
sValue = Replace(sValue, "<", "<")
sValue = Replace(sValue, ">", ">")
CleanupStr = sValue
End If
End Function
I used to spoof the report generator into making html documents for me but this approach has limitations. Firstly when you run the report, it generates rather ugly html and not a print ready report. There is more work after running the report to transform the report into a nice html document that can be opened in a word processor and then saved as a regular document. LibreOffice often is a better recipient of generated html documents than ms-word but occasionally LibreOffice fails to do the job (for a while it had issues with linked images). Word processors ignore css styles so don't bother with styles, direct formatting still works well, particularly for text is tables. If all the exported data is inside a html table, then use LibreOffice as LibreOffice can generate a table of contents based on h1, h2, h3 headings, whereas ms-word cannot.
These days, I just write the entire report as a procedure in a VBA standard module. I still do not use object oriented code and there is no reason to here. Reports written entirely in VBA can be far more sophisticated that what the standard ms-Access report designer can produce. Report designer reports take a lot of tinkering to get the format just right and this consumes time. For complex reports, the VBA approach is actually faster. A report written in VBA can be run every other second, so it is easy to adjust something such as the column width of a table and to rerun the report to check the output. A html report created with VBA is written out as a html file and the ms-access can issue a shell command to open the report in a web browser. If the browser is already open, the new report opens in a new tab so you can see what the previous version looked like as this version will still be open in another tab.
Write the report in a standard module (not in a form module) and call it from some button-click event on the form. The report should only need to be told what the title is, what the output filename and location are and the data scope that the report should output. The report procedure contains all other logic necessary for creating the report. Below is the calling procedure for triggering a report in one of my applications. The purpose of the calling code is to export a list of geotagged photos in a delimited text file so that I can plot the photo locations on a map. The process for exporting a html file is very similar. Some custom functions are in the code below but the structure should be recognisable.
Private Sub cmdCSV_File_Click()
Dim FolderName As String
Dim FileName As String
Dim ReportTitle As String
Dim SQL As String
Dim FixedFields As String
Dim WhereClause As String
Dim SortOrder As String
'Set destination of exported data
FolderName = InputBox("Please enter name of folder to export to", AppName, mDefaultFolder)
If mPaths.FolderExists(FolderName).Success Then
mDefaultFolder = FolderName 'holds default folder name in case it is needed again
Else
MsgBox "Can't find this folder", vbCritical, AppName
Exit Sub
End If
FileName = CheckTrailingSlash(FolderName) & "PhotoPoints.txt"
'Set Report Title
If Nz(Me.chkAllProjects, 0) Then
ReportTitle = "Photos from all Projects"
ElseIf Nz(Me.SampleID, 0) Then
ReportTitle = "Photos from Sample " & Me.SampleID
ElseIf Nz(Me.SurveyID, 0) Then
ReportTitle = "Photos from Survey " & Me.SurveyID
ElseIf Nz(Me.ProjectID, 0) Then
ReportTitle = "Photos from Project " & Me.ProjectID
Else
MsgBox "Please select a scope before pressing this button", vbExclamation, AppName
Exit Sub
End If
'Update paths to photos
If Have(Me.ProjectID) Then
WhereClause = " (PhotoPath_ProjectID = " & Me.ProjectID & ")" 'also covers sample and survey level selections
Else
WhereClause = " True" 'when all records is selected
End If
Call mPhotos.UpdatePhotoPaths(WhereClause) 'refreshes current paths
'Set fixed parts of SQL statement
FixedFields = "SELECT Photos.*, PhotoPaths.PhotoPath_Alias, PhotoPaths.CurrentPath & Photos.PhotoName AS URL, " _
& "PhotoPaths.CurrentPath & 'Thumbs\' & Photos.PhotoName as Thumb " _
& "FROM Photos INNER JOIN PhotoPaths ON Photos.PhotoPathID = PhotoPaths.PhotoPathID WHERE "
SortOrder = " ORDER BY ProjectID, SurveyID, SampleID, Photo_ID"
'set scope for export
WhereClause = "(((Photos.Latitude) Between -90 And 90) AND ((Photos.Longitude) Between -180 And 180) AND ((Photos.Latitude)<>0) AND ((Photos.Longitude)<>0)) AND " & WhereClause
SQL = FixedFields & WhereClause & SortOrder & ";"
'Export data as a delimited list
FileName = ExportCSV(FileName, SQL)
Call OpenBrowser(FileName)
End Sub
The next bit of code actually writes out the delimited text file (html just has tags instead of pipes). The vertical bar or pipe is used to separate the values rather than a comma in this case as commas may occur in the data. The code works out how many columns there are for itself and puts headings at the top.
Public Function ExportCSV(FileAddress As Variant, SQL As String) As String
If Not gDeveloping Then On Error GoTo procerr
PushStack ("mfiles.ExportCSV")
'Exports a csv file
If Nz(FileAddress, "") = "" Then
ExportCSV = "Failed"
Exit Function
End If
'Create text file:
Dim webfile As Object, w
Set webfile = CreateObject("Scripting.FileSystemObject")
Set w = webfile.CreateTextFile(FileAddress, True)
Dim D As Database, R As Recordset, NumberOfFields As Long, Out As String, i As Long
Set D = CurrentDb()
Set R = D.OpenRecordset(SQL, dbOpenSnapshot)
If R.RecordCount > 0 Then
With R
NumberOfFields = .Fields.Count - 1
'Field headings
For i = 0 To NumberOfFields
If i = 0 Then
Out = .Fields(i).Name
Else
Out = Out & "|" & .Fields(i).Name
End If
Next
w.writeline Out
'Field data
Do Until .EOF
For i = 0 To NumberOfFields
If i = 0 Then
Out = .Fields(i)
Else
Out = Out & "|" & .Fields(i)
End If
Next i
w.writeline Out
.MoveNext
Loop
End With
End If
Set R = Nothing
Set D = Nothing
ExportCSV = FileAddress
exitproc:
PopStack
Exit Function
procerr:
Call NewErrorLog(Err.Number, Err.Description, gCurrentProc, FileAddress & ", " & SQL)
Resume exitproc
End Function
Below is a snippet from the openbrowser function. The rest of the function deals with figuring out where the web browser is, as this varies with the version of windows and whether the browser is 32 or 64 bit.
'Set up preferred browser
If Right(BrowserPath, 9) = "Opera.exe" Then
FilePrefix = "file://localhost/"
ElseIf Right(BrowserPath, 11) = "Firefox.exe" Then
FilePrefix = "file:///"
Else
FilePrefix = ""
End If
'Show report
Instruction = BrowserPath & " " & FilePrefix & WebpageName
TaskSuccessID = Shell(Instruction, vbMaximizedFocus)
This example contains about 90% of the code needed to create a html report that has its scope set by the form that calls it. Hope this gets someone over the hump.