How to open a new workbook and add images with VBA? - vba

I'm trying to get a macro for Excel 2007to open a folder with a bunch of images in them. Then Create a new workbook and embed the images into it.
Everything works if I comment out the line Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310 If I uncomment that line I get "Run-time error '434': Object required"
I've check that Sheet.Shapes is returning a Shapes object, it is but the Shapes object is empty. When I try Sheet.Shapes,AddPicture on a workbook that is opened outside of the macro, it adds the images. I've also checked that Sheet.Shapes.AddShape works with the workbook opened in the macro, it does.
At this point, I'm at a lose for what the issue might be. Does anyone have any experience with this sort of thing? Should I be using a different method? Thanks in advance for any help or guidance.
Sub Macro1()
Dim ImagePath, Flist
ImagePath = GetFolder()
If ImagePath = "" Then Exit Sub
Flist = FileList(ImagePath)
Name = "C:\target.xlsm"
Set Book = Workbooks.Add
Set Sheet = Book.Sheets(1)
For i = 1 To 5
cell = "C" + CStr(i)
F = ImagePath + "\" + Flist(i - 1)
Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310
Next
Book.SaveAs FileName:=Name, FileFormat:=52
Book.Close
End Sub
Function FileList(ByVal fldr As String) As Variant
'Lists all the files in the current directory
'Found at http://www.ozgrid.com/forum/showthread.php?t=71409
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & "*.png")
If sTemp = "" Then
FileList = False
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Function GetFolder() As String
Folder:
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "New Screenshot Folder"
.Show
num = .SelectedItems.Count
If .SelectedItems.Count = 0 Then
GetFolder = ""
Else: GetFolder = .SelectedItems(1)
End If
End With
End Function

You can't define a cell by creating the string "C1", that's just the address. The way you did it, cell is a string and a string doesn't have any properties. What you want is a range object so either use
Dim cell As Range
Set cell = sheet.Range("C" & i)
or
Dim cell As Range
Set cell = sheet.Cells(i, 3)
You should always Dim all variables, use Option Explicit on top of your module so you don't forget it ;)
This will often prevent mistakes. Of course you should Dim them with the correct type, i.e. Dim FilePath As String.

The correct command would be:
Sheet.Shapes.AddPicture Filename:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=Range(cell).Left + 5, Top:=Range(cell).Top + 5, Width:=560, Height:=310
I strongly advise you to change your Name variable name, as it will cause errors on recent versions of excel.

Related

Autofilter loop using array

I am having trouble debugging my code. I have an array with the criterial of an autofilter column. My code is supposed to loop through the array, open a set of files and copy-paste information into my workbook.
When I run the code it does not autofiler to the desired criterial and shows a Run-time error 1004. I already tried searching for solutions or similar problems, but found nothing. I also tried recording a macro to change the approach, but when trying to implement the loop it does not work :(
Any help is appreaciated!
Sub Update_Database()
Dim directory As String
Dim fileName As String
Dim my_array() As String
Dim iLoop As Integer
ReDim my_array(18)
my_array(0) = "Aneng"
my_array(1) = "Bayswater"
my_array(2) = "Bad Blankenburg"
my_array(3) = "Halstead"
my_array(4) = "Jorf Lasfar"
my_array(5) = "Kolkatta"
my_array(6) = "Marysville"
my_array(7) = "Northeim"
my_array(8) = "Ponta Grossa"
my_array(9) = "Puchov"
my_array(10) = "Renca"
my_array(11) = "Padre Hurtado"
my_array(12) = "Shanxi"
my_array(13) = "San Luis Potosi"
my_array(14) = "Szeged"
my_array(15) = "Tampere"
my_array(16) = "Uitenhage"
my_array(17) = "Veliki Crljeni"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
directory = .SelectedItems(1)
Err.Clear
End With
fileName = Dir(directory & "\", vbReadOnly)
Dim mwb As Workbook
Set mwb = Workbooks("OEE_Database_Final.xlsm")
Do While fileName <> ""
For iLoop = LBound(my_array) To UBound(my_array)
On erro GoTo ProcExit
With Workbooks.Open(fileName:=directory & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
Selection.AutoFilter Field:=1, Criterial:=my_array(iLoop)
mwb.Worksheets(8).Range("O9:Z2945") = .Worksheets(8).Range("O9:Z2945").Value2
.Close SaveChanges:=False
End With
fileName = Dir
Next iLoop
Loop
ActiveSheet.ShowAllData
ProcExit:
Exit Sub
End Sub

Code error - Saving CSV file asking to overwrite

My code gives me error from
If Dir(Pth, vbArchive) <> vbNullString Then
I havent been able to find the error - Can someone help me what is wrong with the code? Is it supposed to say USERPROFILE, or am i supposed to write something else?
Sub Opgave8()
Dim sh As Worksheet
Dim Pth As String
Application.ScreenUpdating = False
' Create default desktop path using windows user id
user_id = Environ$("USERPROFILE")
' Create full path
file_name$ = "\AdminExport.csv"
Pth = Environ$("USERPROFILE") & "\Desktop\" & FileName
Set sh = Sheets.Add
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
sh.Cells(i, 2) = Worksheets("Base").Cells(i, 4)
End If
Next i
sh.Move
If Dir(Pth, vbArchive) <> vbNullString Then
overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
End If
If overwrite_question = vbYes Then
With ActiveWorkbook
.SaveAs FileName:=Pth, FileFormat:=xlCSV
.Close False
End With
End If
Application.ScreenUpdating = True
End Sub
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
There are a few issues in your code. I don't understand why you are getting an error message, but if you fix your issues, you are in a better position of finding the main problem.
Put Option Explicit at the top. If you do that, you will not do mistakes like setting the variable file_name$ but reading from the variable FileName.
You are building a path with double backslashes. Perhaps not a big thing and it'll probably work. Add a Debug.Print Pth just before your troublesome If. Press Ctrl-G to show the debug pane and study the output. Does the printed file path exist?
Don't use vbNullString. Test with abc <> "" instead.

VBA Convert from text to excel Format cells change from General to numeric for some rows

I have code which compares two folders (textFiles & ExcelFiles), to find if all textFiles are converted to Excel. If not, it calls a function that does this. Everything works well, but when I open the Excel file, the format may change from a row to another in the same column.
This is my code:
Sub LookForNew()
Dim dTxt As String, dExcel As String, key As String
Dim i As Integer
Dim oFileExcel, tFileExl, oFileExl, fso, filsTxt, filsExcel, fil, exl
Set fso = CreateObject("Scripting.FileSystemObject")
Set filsTxt = fso.GetFolder("C:\txtFiles").Files
Set filsExcel = fso.GetFolder("C:\excelFiles").Files
Set oFileExcel = CreateObject("Scripting.Dictionary")
Set tFileExl = CreateObject("Scripting.Dictionary")
Set oFileExl = CreateObject("Scripting.Dictionary")
i = 0
For Each fil In filsTxt
dTxt = fil.Name
dTxt = Left(dTxt, InStr(dTxt, ".") - 1)
For Each exl In filsExcel
dExcel = exl.Name
dExcel = Left(dExcel, InStr(dExcel, ".") - 1)
key = CStr(i)
oFileExcel.Add dExcel, "key"
i = i + 1
Next exl
If Not (oFileExcel.Exists(dTxt)) Then
Call tgr
End If
Next fil
Set fso = Nothing
End Sub
Sub tgr()
Const txtFldrPath As String = "C:\txtFiles"
Const xlsFldrPath As String = "C:\excelFiles"
Dim CurrentFile As String: CurrentFile = Dir(txtFldrPath & "\" & "*.txt")
Dim strLine() As String
Dim LineIndex As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While CurrentFile <> vbNullString
LineIndex = 0
Close #1
Open txtFldrPath & "\" & CurrentFile For Input As #1
While Not EOF(1)
LineIndex = LineIndex + 1
ReDim Preserve strLine(1 To LineIndex)
Line Input #1, strLine(LineIndex)
'STRIP TABS OUT AND REPLACE WITH A SPACE!!!!!
strLine(LineIndex) = Replace(strLine(LineIndex), Chr(9), Chr(32))
Wend
Close #1
With ActiveSheet.Range("A1").Resize(LineIndex, 1)
.Value = WorksheetFunction.Transpose(strLine)
'DEFINE THE OPERATION FULLY!!!!
.TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
End With
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.Copy
ActiveWorkbook.SaveAs xlsFldrPath & "\" & Replace(CurrentFile, ".txt", ".xlsx"), xlOpenXMLWorkbook
ActiveWorkbook.Close False
ActiveSheet.UsedRange.ClearContents
CurrentFile = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This is the picture:
The General format cell changes for some records and becomes a number exp: 4'927'027.00 should be 4927027 like the others.
this is the text file lines
And I want to put a msgBox when there's no Files to convert in "LookForNew" function, but I don't know where.
Question 1: I open the Excel file, the format may change from a row to another in the same column.
Answer: The problem probable lies in your text file. Note what row ,column, and value that isn't formatted properly. Next go to that line and column in your text file. You'll most likely see 4,927,027 or "4927027". In either case Excel might mistake it for a string value.
Question 2: I want to put a msgBox when there's no Files to convert in "LookForNew" function, but I don't know where.
Put a counter in your If Files Exist. You should have your MsgBox after you exit your file loop. - Next fil
This line is miss leading:
oFileExcel.Add dExcel, "key"
correct syntax
dictionary.add key, value
Keys are unique identifiers. Before you add a key to a dictionary you should test to see if the key exist
If not oFileExcel.Exists dExcel then oFileExcel.Add dExcel, ""
Values are references to objects or values.
This line adds the exl file object to oFileExcel dictionary
If not oFileExcel.Exists dExcel then oFileExcel.Add dExcel, exl
This line retrieves the value
Set exl = oFileExcel("SomeKey")
The error is being thrown because you are adding the same key twice. The key values are the name of the Excel file without an extension. Example.xls and Example.xlsx will produce the same key.
That being said, there is no need to use a dictionary. Or to do a file loop in tgr().
I better approach would be
Sub Main
For each textfile
basename = get text file basename
xlfile = xlFileDirectory + baseFileName + excel file extension
if not xlfile Exists then call CreateExcelFromTxt f.Path, xlFileName
End Sub
Sub CreateExcelFromTxt( txtFile, xlFileName)
Open txtFile
Build strLine
Create Excel -> xlFileName
Add strLine to xlFileName
run TextToColumns
End Sub
Here is a starter template
Sub LookForNew()
Const xlFileDirectory = "C:\excelFiles\"
Const txtFileDirectory = C:\txtFiles\"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fso, fld , f, xlFileName
Set fso = WScript.CreateObject("Scripting.Filesystemobject")
Set fld = fso.GetFolder(txtFileDirectory)
Set txtFiles = fso.GetFolder(txtFileDirectory).Files
For Each f In txtFiles
baseFileName = Left(f.Name,InStrRev(f.Name,".")-1)
xlFilePath = xlFileDirectory & baseFileName & ".xlsx"
If Not fso.FileExists(xlFilePath ) Then CreateExcelFromText f.Path, xlFileName
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub CreateExcelFromText(txtFileName, xlFileName)
End Sub

Exporting PowerPoint sections into separate files

Every week I separate a long PowerPoint file into separate files. The files must be in PowerPoint format, and contain only the slides that are contained in the 'sections' from the PowerPoint file.
I need to:
1) Scan to see the number of slides in a given section
2) Make a file containing the slides within that section
3) Name that file the same as the name of the section, and save it in the same directory as the source file.
4) Repeat the process for subsequent sections.
5) Do this without damaging the original file.
I've located code (http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm) that can break the file into many parts, but only by the number of files requested per file. I found some other helpful references here: http://skp.mvps.org/2010/ppt001.htm
I have coded in Basic and a number of easy gaming scripting languages. I need help understanding how this is done in VBA.
Since you do this very often, you should make an Add-In for this. The idea is to create copies of the presentation up to the number of sections in it, then open each one and delete the other sections and save.
Create blank presentation with macros enabled (*.pptm) and possibly add Custom UI button to call SplitIntoSectionFiles
Test and when satisfy, save as PowerPoint Add-In (*.ppam). Don't delete the pptm file!
Assuming that all are pptx files you are dealing with, you can use this code. It opens the splited pptx files in background, then remove irrelevant sections and save, close. If all goes well you get a message box.
Private Const PPT_EXT As String = ".pptx"
Sub SplitIntoSectionFiles()
On Error Resume Next
Dim aNewFiles() As Variant, sPath As String, i As Long
With ActivePresentation
sPath = .Path & "\"
For i = 1 To .SectionProperties.Count
ReDim Preserve aNewFiles(i)
' Store the Section Names
aNewFiles(i - 1) = .SectionProperties.Name(i)
' Force Save Copy as pptx format
.SaveCopyAs sPath & aNewFiles(i - 1), ppSaveAsOpenXMLPresentation
' Call Sub to Remove irrelevant sections
RemoveOtherSections sPath & aNewFiles(i - 1) & PPT_EXT
Next
If .SectionProperties.Count > 0 And Err.Number = 0 Then MsgBox "Successfully split " & .Name & " into " & UBound(aNewFiles) & " files."
End With
End Sub
Private Sub RemoveOtherSections(sPPT As String)
On Error Resume Next
Dim oPPT As Presentation, i As Long
Set oPPT = Presentations.Open(FileName:=sPPT, WithWindow:=msoFalse)
With oPPT
' Delete Sections from last to first
For i = .SectionProperties.Count To 1 Step -1
' Delete Sections that are not in the file name
If Not InStr(1, .Name, .SectionProperties.Name(i), vbTextCompare) = 1 Then
' Delete the Section, along with the slides associated with it
.SectionProperties.Delete i, True
End If
Next
.Save
.Close
End With
Set oPPT = Nothing
End Sub
Read about Custom UI if you don't have experience creating you own ribbon tab: msdn and use the "Office Custom UI Editor", I would use imageMso "CreateModule" for the button.
None of the proposed routines actually works, so I wrote mine from scratch:
Sub Split()
Dim original_pitch As Presentation
Set original_pitch = ActivePresentation
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With original_pitch
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, fso.GetBaseName(.Name) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
Dim i As Long
For i = 1 To original_pitch.SectionProperties.Count
Dim pitch_segment As Presentation
Set pitch_segment = Presentations.Open(Replace(original_pitch.FullName, "pptm", "pptx"))
section_name = pitch_segment.SectionProperties.Name(i)
For k = original_pitch.SectionProperties.Count To 1 Step -1
If pitch_segment.SectionProperties.Name(k) <> section_name Then pitch_segment.SectionProperties.Delete k, True
Next k
With pitch_segment
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, original_pitch.SectionProperties.Name(i) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Next i
MsgBox "Split completed successfully!"
End Sub
I could not get the above code to work.
However this is simpler and does work:
Sub SplitToSectionsByChen()
daname = ActivePresentation.Name
For i = 1 To ActivePresentation.SectionProperties.Count
For j = ActivePresentation.SectionProperties.Count To 1 Step -1
If i <> j Then ActivePresentation.SectionProperties.Delete j, True
Next j
ActivePresentation.SaveAs ActivePresentation.SectionProperties.Name(1)
ActivePresentation.Close
Presentations.Open (daname)
Next i
End Sub
I have edited fabios code a bit to look like this. And this works well for me in my PC
Option Explicit
Sub Split()
Dim original_File As Presentation
Dim File_Segment As Presentation
Dim File_name As String
Dim DupeName As String
Dim outputFname As String
Dim origName As String
Dim lIndex As Long
Dim K As Long
Dim pathSep As String
pathSep = ":"
#If Mac Then
pathSep = ":"
#Else
pathSep = "/"
#End If
Set original_File = ActivePresentation
DupeName = "TemporaryFile.pptx"
DupeName = original_File.Path & pathSep & DupeName
original_File.SaveCopyAs DupeName, ppSaveAsOpenXMLPresentation
origName = Left(original_File.Name, InStrRev(original_File.Name, ".") - 1)
For lIndex = 1 To original_File.SectionProperties.Count
If original_File.SectionProperties.SlidesCount(lIndex) > 0 Then
Set File_Segment = Presentations.Open(DupeName, msoTrue, , msoFalse)
File_name = File_Segment.SectionProperties.Name(lIndex)
For K = original_File.SectionProperties.Count To 1 Step -1
If File_Segment.SectionProperties.Name(K) <> File_name Then
Call File_Segment.SectionProperties.Delete(K, 1)
End If
Next K
outputFname = pathSep & origName & "_" & original_File.SectionProperties.Name(lIndex) & "_" & Format(Date, "YYYYMMDD")
With File_Segment
.SaveAs FileName:=.Path & outputFname & ".pptx", FileFormat:=ppSaveAsOpenXMLPresentation
.Close
End With
Set File_Segment = Nothing
End If
Next
Set original_File = Nothing
Kill DupeName
MsgBox "Split completed successfully!"
End Sub
This works for me (except for the filename):
Option Explicit
Sub ExportSlidesAsPresentations()
Dim oPres As Presentation
Dim sSlideOutputFolder As String
Set oPres = ActivePresentation
sSlideOutputFolder = oPres.Path & "\"
'Export all the slides in the presentation
Call oPres.PublishSlides(sSlideOutputFolder, True, True)
Set oPres = Nothing
End Sub

Open PowerPoint from directory and resume macro

I'm trying to open a PPTX from a specific folder using a Function within a Sub. The function's purpose is to choose the file that the rest of the macro's code will perform it on (essentially to make it the ActivePresentation) The problem is that when I call the function PickDir() to get the file's path and open it, the macro stops running. So, I just get an open presentation and not performing the action I want it to do.
The problem occurs about 5 lines after all the variables are Dim'd.
Sub ExtractImagesFromPres()
On Error GoTo ErrorExtract
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim ImgCtr As Integer
Dim SldCtr As Integer
Dim ShapeNameArray() As String
Dim oPP As Object
Dim SrcDir As String
Dim SrcFile As String
'File naming variables
Dim PPLongLanguageCode As String
Dim PPShortLanguageCode As String
Dim FNShort As String
Dim FNLong As String
Dim PPLanguageParts1() As String
Dim PPLanguageParts2() As String
Dim FNLanguageParts() As String
SrcDir = PickDir() 'call the PickDir() function to choose a directory to work from
If SrcDir = "" Then Exit Sub
SrcFile = SrcDir & "\" & Dir(SrcDir + "\*.pptx") 'complete directory path of ppt to be split
Set oPP = CreateObject("Powerpoint.Application") 'open ppt containing slides with images/text to be exported
ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
ImgCtr = 0 'Image and Slide counter for error messages
SldCtr = 1
ReDim ShapeNameArray(1 To 1) As String 'initialize ShapeNameArray to avoid null array errors
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes 'loop each shape within each slide
If oShpSource.Type <> msoPlaceholder Then 'if shape is not filename placeholder then add it's name to ShapeNameArray
ShapeNameArray(UBound(ShapeNameArray)) = oShpSource.Name
ReDim Preserve ShapeNameArray(1 To UBound(ShapeNameArray) + 1) As String 'need to add one to array for new shape name
ElseIf oShpSource.Type = msoPlaceholder Then 'is shape is filename placeholder then check to see if not empty
If oShpSource.TextFrame.TextRange.Length = 0 Then
MsgBox "The filename is missing on Slide:" & SldCtr & vbNewLine & _
"Please enter the correct filname and re-run this macro"
Exit Sub
End If
PPLanguageParts1 = Split(ActivePresentation.Name, ".") 'extract language code from PowerPoint filename
PPLongLanguageCode = PPLanguageParts1(LBound(PPLanguageParts1))
PPLanguageParts2 = Split(PPLongLanguageCode, "_")
PPShortLanguageCode = PPLanguageParts2(UBound(PPLanguageParts2))
FNLanguageParts = Split(oShpSource.TextFrame.TextRange.Text, "_") 'insert PowerPoint filename language code into image filename language code
FNShort = FNLanguageParts(LBound(FNLanguageParts))
FNLong = FNShort & "_" & PPShortLanguageCode
oShpSource.TextFrame.TextRange.Text = FNLong
End If
Next oShpSource
ReDim Preserve ShapeNameArray(1 To UBound(ShapeNameArray) - 1) As String 'ShapeNameArray has one too many elements, so subtract one
Call oSldSource.Shapes.Range(ShapeNameArray).Export(FNLong & ".jpg", ppShapeFormatJPG) 'export images with proper filenames
ReDim ShapeNameArray(1 To 1) As String
ImgCtr = ImgCtr + 1
SldCtr = SldCtr + 1
Next oSldSource
If ImgCtr = 0 Then 'error message if no images
MsgBox "There were no images found in this presentation", _
vbInformation, "Image extraction failed."
End If
Exit Sub
ErrorExtract:
If Err.Number <> 0 Then 'error message log
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
End If
End Sub
Private Function PickDir() As String
Dim FD As FileDialog
PickDir = ""
Set FD = Application.FileDialog(msoFileDialogFolderPicker) 'initialize default MS directory picker
With FD
.Title = "Pick the folder where your files are located" 'title for directory picker dialog box
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
PickDir = .SelectedItems(1)
End If
End With
Are you running this from within powerpoint? If yes, you don't need to create another Application object: you can just open the ppt directly. And you can use the return value from Open() to get a reference to the presentation (rather than using "activePresentation")
Dim ppt as Presentation
Set ppt = Application.Presentations.Open(SrcFile, False, False, True)
'do stuff with ppt
This line is probably giving you some trouble:
ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
I don't know how to activate a window in PPT but at the very least you'll need to use the following:
Set ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)
As for activating the presentation, you may need to access the windows collection, or something similar? A suggestion, hopefully to get you thinking.
application.Presentations(1).Windows(1).Activate
Finally, you may actually not need to activate the presentation, if you have no other presentations open, the one you're opening will quite likely be the active one by default, if you open it visible. I suspect this is the case, given that you are creating the powerpoint application object. If this is correct then you simply need to do the following:
oPP.Presentations.Open(SrcFile, False, False, True)
debug.print oPP.ActivePresentation.Name
Edit: I'd also recommend setting a reference to the powerpoint object library and declaring oPP as follows:
Dim oPP as Powerpoint.Application
Then when creating an instance of the application:
Set oPP = New Powerpoint.Application
If you don't want to have to worry about which presentation is active, you can do:
Dim oPres as Presentation
Set oPres = oPP.Presentations.Open(SrcFile, False, False, True)
Then in the rest of the code, use oPres instead of ActivePresentation