I have a macro which opens a PowerPoint file stored on the workbook and then modifies it using the below code
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
Dim TsyTemplate As Object
Set TsyTemplate = ThisWorkbook.Sheets("Report Templates").OLEObjects(“Report 1”)
TsyTemplate.Copy
Sheets("Version Control").Paste
Set TsyTemplate = ThisWorkbook.Sheets("Book 1").OLEObjects(1)
TsyTemplate.Verb Verb:=xlOpen
Set TsyTemplate = Nothing
Set PPres = PApp.ActivePresentation
This works fine however I want to add some code which then converts the open PowerPoint file into a PDF file. I would prefer it to just convert it without saving it somewhere but I don't believe this is possible so I am using he below code to save it as a PDF FILE
PDFName = ActiveWorkbook.Path & "/test.pdf"
PPres.ExportAsFixedFormat Path:=PDFName, FixedFormatType:=ppFixedFormatTypePDF, RangeType:=ppPrintSelection
This isn't working though as I get the error message "type mismatch"
Does anyone have any suggestions as to what I am doing wrong.
Thanks
Full code:
Global PApp As Object
Global PPres As Object
Global PPTFileName As String
Global ppFixedFormatTypePDF As Long
Global ppPrintSelection As Long
Sub Test_Printing_To_PDF()
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
Dim TsyTemplate As Object
Set TsyTemplate = ThisWorkbook.Sheets("Report Templates").OLEObjects("Report 1")
TsyTemplate.Copy
Sheets("Version Control").Paste
Set TsyTemplate = ThisWorkbook.Sheets("Version Control").OLEObjects(1)
TsyTemplate.Verb Verb:=xlOpen
Set TsyTemplate = Nothing
Set PPres = PApp.ActivePresentation
PPres.Slides(1).Shapes("Presentation_Title").TextFrame.TextRange.Text = "Test printing code"
ppFixedFormatTypePDF = 2
ppPrintSelection = 2
PDFName = ActiveWorkbook.Path & "/test.pdf"
PPres.ExportAsFixedFormat Path:=PDFName, FixedFormatType:=ppFixedFormatTypePDF, RangeType:=ppPrintSelection
End Sub
I removed some of your Excel code so that I could try this here; since it seems to have nothing to do with the PDF export from PPT, shouldn't make any difference. New (working) code below with comments:
Option Explicit
Global PApp As Object
Global PPres As Object
Global PPTFileName As String
Global ppFixedFormatTypePDF As Long
Global ppPrintSelection As Long
Const ppSaveAsPDF As Long = 32
Sub Test_Printing_To_PDF()
' Always include Option Explicit and DIM all variables
Dim Pth As String
Dim ErrorPopUp As Boolean
Dim PDFName As String
Set PApp = CreateObject("PowerPoint.Application")
PApp.Visible = True
Pth = ThisWorkbook.Path
ErrorPopUp = True
' Just invoking PowerPoint doesn't necessarily create a presentation.
' You need to add one (or open an existing one)
Set PPres = PApp.presentations.Add
' And creating a new presentation doesn't necessarily add slides so:
PPres.slides.Add 1, 1
' Unless you've opened a presentation that happens to have a shape named
' Presentation_Title on the first slide, this will fail:
'PPres.slides(1).Shapes("Presentation_Title").TextFrame.TextRange.Text = "Test printing code"
' So I've changed it to this:
PPres.slides(1).Shapes(1).TextFrame.TextRange.Text = "Test printing code"
' / isn't a valid character:
'PDFName = ActiveWorkbook.Path & "/test.pdf"
' so I changed it to this:
PDFName = ActiveWorkbook.Path & "\test.pdf"
' And there are all sorts of reports all over the net about
' the Export routine being buggy. Substitute this and it works:
PPres.SaveAs PDFName, ppSaveAsPDF
End Sub
Related
I am trying to write a function which will delete all sheets except the one passed as parameter. Below function is being called but function does not delete any sheets. How can I delete all worksheets except one?
........
Set ExcelObj = createobject("excel.application")
ExcelObj.Visible = true
Set ConfigFile = ExcelObj.Workbooks.Open (FilePath)
Set ConfigSheet = ConfigFile.Worksheets("Scripts")
Set ConfigApplicationSheet = ConfigFile.Worksheets("Applications")
Set ExecutiveSummarySheet = ConfigFile.Worksheets("Summary")
ExcelObj.ActiveWorkBook.SaveAs SummaryFilePath
DeleteSheet "ConfigScripSheet","Summary"
Function DeleteSheet(ConfigSheet,mySheetname)
'Writing Name and Path of each File to Output File
For Each ObjFile In ObjFiles
ObjOutFile.WriteLine(ObjFile.Name & String(50 - Len(ObjFile.Name), " ") & ObjFile.Path)
Next
ObjOutFile.Close
DeleteSheet = 0
ExcelObj.DisplayAlerts = False
For Each objWorksheet In ConfigSheet.Worksheets
If not objWorksheet.Name = mySheetname Then
DeleteSheet = 1
ConfigScripSheet.sheets(objWorksheet.Name).Select
ConfigScripSheet.sheets(objWorksheet.Name).Delete
ExcelObj.DisplayAlerts = False
End If
Next
End Function
Trying to correct your code above was too much of a minefield for me as I couldn't tell what you meant in several places - so I rewrote it based on what you had said in the description was your goal.
The code below will open the file, associate the objects the way you had them, pass the workbook object and a sheet name not to be deleted into the DeleteSheet function, which will delete any sheet in the workbook that is not named as per the passed in parameter SheetNameNotToDelete
Let me know if any of the code is unclear.
Option Explicit ' Forces declaration of variables
Dim FilePath, SummaryFilePath '<-- Need set to some value!
FilePath = ""
SummaryFilePath = ""
Dim ExcelObj : Set ExcelObj = CreateObject("Excel.Application")
Dim ConfigFile : Set ConfigFile = ExcelObj.Workbooks.Open(FilePath)
Dim ConfigSheet : Set ConfigSheet = ConfigFile.Worksheets("Scripts")
Dim ConfigApplicationSheet : Set ConfigApplicationSheet = ConfigFile.Worksheets("Applications")
Dim ExecutiveSummarySheet : Set ExecutiveSummarySheet = ConfigFile.Worksheets("Summary")
ExcelObj.ThisWorkbook.SaveAs SummaryFilePath
DeleteSheet ConfigFile, "Summary"
Function DeleteSheet(ByRef WorkbookObj, ByVal SheetNameNotToDelete)
Dim oWorksheet
For Each oWorksheet In WorkbookObj.Worksheets
If oWorksheet.Name <> SheetNameNotToDelete And WorkbookObj.Worksheets.Count >=2 Then
oWorksheet.Delete ' Excel won't let you delete all worksheets from a workbook
End If ' the check on Count >=2 covers the case where no worksheet exists
Next ' called "Summary" to be left
End Function
I'm using this with HP Operations Manager, which uses the PARAMETER section so you can define variables from within the HPOM policy. This currently works for the one file hardcoded, but I want to be able to use the PARAMETER to set a filename, so the script is universal.
What this does is to check whether a specific file exists, and sets a variable (Rule.Status = True) if it is older than some amount of minutes specified in the FileAge variable.
Right now I am using:
Set MonitorFile = MonitorFolder.Files("EDI.001")
That works fine. But when I try to do:
Set MonitorFile = MonitorFolder.Files(FileName)
It fails with following error:
Invalid procedure call or argument.
Am I doing something wrong? Is there a better way of using a variable in this scenario?
Here is the whole script:
'PARAMETERS START
'PARAMETER FolderName STRING DEFAULT "D:\RFInput\InBoxPO" VALUE "D:\RFInput\InBoxPO\" SESSION
Dim FolderName
FolderName = "D:\RFInput\InBoxPO\"
Session("FolderName") = FolderName
'PARAMETER FileAge INT DEFAULT "60" VALUE "1" SESSION
Dim FileAge
FileAge = 1
Session("FileAge") = FileAge
'PARAMETER FolderDisplayName STRING DEFAULT "InBoxPO" VALUE "InBoxPO" SESSION
Dim FolderDisplayName
FolderDisplayName = "InBoxPO"
Session("FolderDisplayName") = FolderDisplayName
'PARAMETER FileName STRING DEFAULT "EDI.001" VALUE "EDI.001" SESSION
Dim FileName
FileName = "EDI.001"
Session("FileName") = FileName
'PARAMETERS END
Dim fs, MonitorFolder, MonitorFile, objShell, MinutesOld
Dim objFile, listNames
' Set constants for working with files
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set objShell = CreateObject("Shell.Application")
Set fs = CreateObject("Scripting.FileSystemObject")
Set MonitorFolder = fs.GetFolder(FolderName)
Rule.Status = False
For Each objFile In MonitorFolder.Files
listNames = objFile.Name
If InStr(listNames, FileName) = 1 Then
Set MonitorFile = MonitorFolder.Files("EDI.001")
MinutesOld = DateDiff("n", MonitorFile.DateLastModified, Now)
If MinutesOld > FileAge Then
'Turn on for debugging - Wscript.Echo FileName & " is older than " & FileAge & " minutes in folder " & FolderName & "."
Rule.Status = True
End If
End If
Next
Set objShell = Nothing
Set fs = Nothing
Set MonitorFolder = Nothing
'END OF SCRIPT
Indeed access to specific items in the Files collection seems to work only with string literals, not sure why that is.
You can simplify the For Each loop, though:
For Each objFile In MonitorFolder.Files
If LCase(objFile.name) = LCase(FileName) Then
Set MonitorFile = objFile
...
End If
Next
If you require lookup by filename you could build a dictionary like this:
Set filenames = CreateObject("Scripting.Dictionary")
For Each objFile In MonitorFolder.Files
filenames.Add objFile.Name, objFile
Next
That will allow you to access the files by name like this:
Set MonitorFile = filenames(FileName)
We want to upgrade our VB6 code to use Outlook 2010, but we're getting the following error:
Active x cannot create object
This is our current code:
Public Sub SendEmail()
Set emailOutlookApp = CreateObject("Outlook.Application.12")
Set emailNameSpace = emailOutlookApp.GetNamespace("MAPI")
Set emailFolder = emailNameSpace.GetDefaultFolder(olFolderInbox)
Set emailItem = emailOutlookApp.CreateItem(olMailItem)
Set EmailRecipient = emailItem.Recipients
EmailRecipient.Add (EmailAddress)
EmailRecipient.Add (EmailAddress2)
emailItem.Importance = olImportanceHigh
emailItem.Subject = "My Subject"
emailItem.Body = "The Body"
'-----Send the Email-----'
emailItem.Save
emailItem.Send
'-----Clear out the memory space held by variables-----'
Set emailNameSpace = Nothing
Set emailFolder = Nothing
Set emailItem = Nothing
Set emailOutlookApp = Nothing
Exit Sub
I'm not sure if "Outlook.Application.12" is correct. But I can't find a definitive answer for this.
For Outlook 2010, this is definitly corect Outlook.Application.14.
But, I don't know what about office 2007.
I think it's Outlook.Application.12 and for lower versions it is simply "Outlook.Application".
Here's the code I switched to for 2010:
Private Sub EmailBlahbutton_Click()
Dim mOutlookApp As Object
Dim OutMail As Object
Dim Intro As String
On Error GoTo ErrorHandler
Set mOutlookApp = GetObject("", "Outlook.application")
Set OutMail = mOutlookApp.CreateItem(0)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'These are the ranges being emailed.
ActiveSheet.Range(blahblahblah).Select
'Intro is the first line of the email
Intro = "BLAHBLAHBLHA"
'Set the To and Subject lines. Send the message.
With OutMail
.To = "blahblah#blah.com"
.Subject = "More BLAH here"
.HTMLBody = Intro & RangetoHTML(Selection)
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
ActiveSheet.Range("A1").Select
ActiveWindow.ScrollColumn = ActiveCell.Column
ActiveWindow.ScrollRow = ActiveCell.Row
Set OutMail = Nothing
Set mOutlookApp = Nothing
Exit Sub
ErrorHandler:
Set mOutlookApp = CreateObject("Outlook.application")
Resume Next
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Why do you explicitly specify the version? Why not simply
Set emailOutlookApp = CreateObject("Outlook.Application")
Try "Outlook.Application.14". Not sure if this is related though: 2007 to 2010 upgrade issue
I realize it's not the exact issue, but it may lead you down the right path.
Following the howto Extending the Active Directory Schema To Track Custom Info I'm able to setup a single-value schema attribute that is easily changeable via a context menu in ADUC. Multi-value schema attributes get considerably more complicated. Say (for the sake of argument) my value is "Projects" and each user may be a list as many projects as necessary.
Following is a sad little script that will set Project to a single value:
Dim oproject
Dim oUser1
Dim temp1
Set oproject = Wscript.Arguments
Set oUser1 = GetObject(oproject(0))
temp1 = InputBox("Project: " & oUser1.project & vbCRLF & vbCRLF & "Project")
if temp1 <> "" then oUser1.Put "project",temp1
oUser1.SetInfo
Set oUser1 = Nothing
Set oproject = Nothing
Set temp1 = Nothing
WScript.Quit
How can I modify this to allow, assign, and modify multiple values?
I gave up on an elegant UI and just went with the semicolon delimited list. Here's the code if anyone cares:
Dim objProject
Dim objUser
Dim temp1, title, message, default
Dim projects
title = "Projects"
Set objProject = Wscript.Arguments
Set objUser = GetObject(objProject(0))
'Find our current projects
projects = objUser.projects
If Not isArray(projects) Then
projects = Array(projects)
End If
'Setup our message box
message = "Semicolon-delimited list of Projects"
default = arrayToStr(projects)
temp1 = InputBox(message, title, default)
'catch cancels
if IsEmpty(temp1) Then
WScript.Quit
End If
' update our data
projects = strToArray(temp1)
objUser.Put "projects",projects
objUser.SetInfo
'Clean up and quit
Set projects = Nothing
Set objUser = Nothing
Set objProject = Nothing
Set temp1 = Nothing
Set title = Nothing
Set message = Nothing
Set default = Nothing
WScript.Quit
'Functions
Function strToArray(s)
Dim a
Dim token
' discard blank entries
For Each token in split(s, ";")
token = trim(token)
If token <> "" Then
If isEmpty(a) Then
a = token
Else
a = a & ";" & token
End If
End If
Next
' return array
strToArray = split(a, ";")
End Function
Function arrayToStr(a)
Dim s
Dim token
For Each token in a
If isEmpty(s) Then
s = token
Else
s = s & ";" & token
End If
Next
' return string
arrayToStr = s
End Function
I'm working on an Outlook add-in that requires the Office specific FileDialog to interoperate with a Sharepoint site; the common file dialog doesn't have the interoperability. I know that both Word and Excel have a get_fileDialog method under Globals.ThisAddIn.Application.Application, but Outlook doesn't seem to. How do I launch an Outlook FileDialog? Is it even possible?
Microsoft Common Dialog
If you have COMDLG32.OCX ("Common Dialog ActiveX Control") installed, then you can use this - it's explained here, with an example. (Scroll down just past the screenshot entitled "FIGURE 2: Don't try to select more than one file in Word! ").
It appears that Outlook's Application object does not offer FileDialog. But a simple workaround, if you are willing to have an Excel reference, is:
Dim fd As FileDialog
Set fd = Excel.Application.FileDialog(msoFileDialogFolderPicker)
Dim folder As Variant
If fd.Show = -1 Then
For Each folder In fd.SelectedItems
Debug.Print "Folder:" & folder & "."
Next
End If
'Add a "Module". Then add the declarations like this to it.
Option Explicit
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function MyOpenFiledialog() As String
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
'Set the parent window
OFName.hwndOwner = Application.hWnd
'Set the application's instance
OFName.hInstance = Application.hInstance
'Select a filter
OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'create a buffer for the file
OFName.lpstrFile = Space$(254)
'set the maximum length of a returned file
OFName.nMaxFile = 255
'Create a buffer for the file title
OFName.lpstrFileTitle = Space$(254)
'Set the maximum length of a returned file title
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = "C:\"
'Set the title
OFName.lpstrTitle = "Open File - VB Forums.com"
'No flags
OFName.flags = 0
'Show the 'Open File'-dialog
If GetOpenFileName(OFName) Then
MsgBox "File to Open: " + Trim$(OFName.lpstrFile)
MyOpenFiledialog = Trim$(OFName.lpstrFile)
Else
MsgBox "Cancel was pressed"
MyOpenFiledialog = vbNullString
End If
End Sub 'Usage:
Private Sub Command1_Click()
Text1.Text = MyOpenFiledialog
End Sub
Public Sub TestFileDialog()
Dim otherObject As Excel.Application
Dim fdFolder As office.FileDialog
Set otherObject = New Excel.Application
otherObject.Visible = False
Set fdFolder = otherObject.Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.Show
Debug.Print fdFolder.SelectedItems(1)
otherObject.Quit
Set otherObject = Nothing
End Sub
Private Sub multiEML2MSG()
Const PR_ICON_INDEX = &H10800003
Dim objPost As Outlook.PostItem
Dim objSafePost As Redemption.SafePostItem
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Set objNS = Outlook.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objPost = objInbox.Items.Add(OlItemType.olPostItem)
Set objSafePost = New Redemption.SafePostItem
Dim xlObj As Excel.Application
Dim fd As Office.FileDialog
Set xlObj = New Excel.Application
Set fd = xlObj.Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select your PST File"
.ButtonName = "Ok"
.Show
If fd.SelectedItems.Count <> 0 Then
xDirect$ = fd.SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
licznik = 1
Do While xFname$ <> ""
XPathEML = xDirect$ & xFname$
XPathMSG = Replace(XPathEML, ".eml", ".msg", , , vbTextCompare)
Debug.Print XPath, Replace(XPath, ".eml", ".msg", , , vbTextCompare)
objPost.Save
objSafePost.Item = objPost
objSafePost.Import XPathEML, Redemption.RedemptionSaveAsType.olRFC822
objSafePost.MessageClass = "IPM.Note"
objSafePost.Fields(PR_ICON_INDEX) = none
objSafePost.SaveAs XPathMSG, Outlook.OlSaveAsType.olMSG
xFname$ = Dir
licznik = licznik + 1
Loop
End If
End With
xlObj.Quit
Set xlObj = Nothing
Set objSafePost = Nothing
Set objPost = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub