Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 552
  • Last Modified:

VBA Excel Code Processing Delay

All,

I have a procedure that transfers a number of records from excel into a powerpoint slide table, then publishes the powerpoint presentation as PDF. The function works fine (does not bug at all) however, when it gets to step to save the powerpoint to PDF it hangs and requires me to click on the excel application in my taskbar before it prompts me to name the PDF file before publishing.

Note, both files are macro-enabled.

I have enclosed the code for this routine with the hope that someone can help me isolate the problem that is causing it?

CF
Private Sub CmdQuote_Click()
'GENERATES SALES PACK USING THE CALCULATOR PRODUCED BY THE USER

    Dim oPPTApp As PowerPoint.Application
    Dim oPPTShape As PowerPoint.Shape
    Dim oPPTFile As PowerPoint.Presentation
    Dim SlideNum As Integer, FileName As String, pdfName As String, vFilePathAddressToUse As String, _
    strExcelFilePath As String, strNewPresPath As String, FileFormatstr As String, Fname As Variant, newName As String
    
    'COLLECTING THE CURRENT WORKBOOK NAME ==>
    newName = ActiveWorkbook.Name
    
    'COLLECTING THE FILE PATH USER ADDRESS ==>
    Dim vFilePathUserAddress As String
    Dim vUserName As String
    vUserName = Environ("USERNAME")
    vFilePathUserAddress = "C:\Users\" & vUserName & "\Documents\PROTEGE\Sales Pack Master.pptm"
        
    'PERFORMING TESTS OF NETWORK FOLDER EXISTANCES ==>
    If FileFolderExists("\\PROTEGE-PC\Users\Public\Documents\PROTEGE GROUP\20_LED_SALES\Sales Pack Master.pptm") Then
        vFilePathAddressToUse = "\\PROTEGE-PC\Users\Public\Documents\PROTEGE GROUP\20_LED_SALES\Sales Pack Master.pptm"
    ElseIf FileFolderExists(vFilePathUserAddress) Then
        vFilePathAddressToUse = "C:\Users\" & vUserName & "\Documents\PROTEGE\Sales Pack Master.pptm"
    Else: MsgBox ("Cannot locate your master pack file...")
        Exit Sub
    End If
    
    'TURNING OFF ALL WARNINGS AND PROMPTS ==>
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    'DISPLAYING PROGRESS BAR ==>
    ProgressStatus.show vbModeless
    
    'CREATING POWERPOINT APPLICATION ==>
    Set oPPTApp = CreateObject("PowerPoint.Application")
    oPPTApp.Visible = msoTrue
    Set oPPTFile = oPPTApp.Presentations.Open(vFilePathAddressToUse)
    SlideNum = 4
    oPPTFile.Slides(SlideNum).Select
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Outs")
    
    'SHEET SELECT ==>
    Sheets("IMPALA").Activate
    
    'ROW 1 "LAMP_LIFE"
    oPPTShape.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = Cells(12, 4).Text 'x = Row, y = Column
    oPPTShape.Table.Cell(1, 3).Shape.TextFrame.TextRange.Text = Cells(12, 8).Text
    oPPTShape.Table.Cell(1, 4).Shape.TextFrame.TextRange.Text = Cells(12, 12).Text
    
    ProgressStatus.ProgressBar1.Value = 10
    DoEvents
    
    'ROW 2 "REPLACEMENT_FREQUENCY"
    oPPTShape.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(13, 4).Text 'x = Row, y = Column
    oPPTShape.Table.Cell(2, 3).Shape.TextFrame.TextRange.Text = Cells(13, 8).Text
    oPPTShape.Table.Cell(2, 4).Shape.TextFrame.TextRange.Text = Cells(13, 12).Text
    
    'ROW 3 "LAMPING COST PER HOUR"
    oPPTShape.Table.Cell(3, 2).Shape.TextFrame.TextRange.Text = Format(Cells(14, 4).Text, "$#,##")  'x = Row, y = Column
    oPPTShape.Table.Cell(3, 3).Shape.TextFrame.TextRange.Text = Format(Cells(14, 8).Text, "$#,##")
    oPPTShape.Table.Cell(3, 4).Shape.TextFrame.TextRange.Text = Format(Cells(14, 12).Text, "$#,##")
    
    ProgressStatus.ProgressBar1.Value = 20
    DoEvents
    
    'ROW 4 "LAMPING REPLACEMENT COST"
    oPPTShape.Table.Cell(4, 2).Shape.TextFrame.TextRange.Text = Format(Cells(15, 4).Text, "$#,##")  'x = Row, y = Column
    oPPTShape.Table.Cell(4, 3).Shape.TextFrame.TextRange.Text = Format(Cells(15, 8).Text, "$#,##")
    oPPTShape.Table.Cell(4, 4).Shape.TextFrame.TextRange.Text = Format(Cells(15, 12).Text, "$#,##")
    
        
    'ROW 5 "REPLACEMENT CAPITAL COST"
    oPPTShape.Table.Cell(5, 2).Shape.TextFrame.TextRange.Text = Format(Cells(16, 4).Text, "$#,##")  'x = Row, y = Column
    oPPTShape.Table.Cell(5, 3).Shape.TextFrame.TextRange.Text = Format(Cells(16, 8).Text, "$#,##")
    oPPTShape.Table.Cell(5, 4).Shape.TextFrame.TextRange.Text = Format(Cells(16, 12).Text, "$#,##")
    
    ProgressStatus.ProgressBar1.Value = 30
    DoEvents
    
    'ROW 6 "TOTAL CAPITAL COST"
    oPPTShape.Table.Cell(6, 2).Shape.TextFrame.TextRange.Text = Format(Cells(17, 4).Text, "$#,##") 'x = Row, y = Column
    oPPTShape.Table.Cell(6, 3).Shape.TextFrame.TextRange.Text = Format(Cells(17, 8).Text, "$#,##")
    oPPTShape.Table.Cell(6, 4).Shape.TextFrame.TextRange.Text = Format(Cells(17, 12).Text, "$#,##")
      
    'ROW 7 "POWER CONSUMPTION PER HOUR"
    oPPTShape.Table.Cell(7, 2).Shape.TextFrame.TextRange.Text = Cells(19, 4).Text 'x = Row, y = Column
    oPPTShape.Table.Cell(7, 3).Shape.TextFrame.TextRange.Text = Cells(19, 8).Text
    oPPTShape.Table.Cell(7, 4).Shape.TextFrame.TextRange.Text = Cells(19, 12).Text
    
    ProgressStatus.ProgressBar1.Value = 40
    DoEvents
    
    'ROW 8 "POWER CONSUMPTION PER ANNUM"
    oPPTShape.Table.Cell(8, 2).Shape.TextFrame.TextRange.Text = Format(Cells(20, 4).Text, "#,##") 'x = Row, y = Column
    oPPTShape.Table.Cell(8, 3).Shape.TextFrame.TextRange.Text = Format(Cells(20, 8).Text, "#,##")
    oPPTShape.Table.Cell(8, 4).Shape.TextFrame.TextRange.Text = Format(Cells(20, 12).Text, "#,##")
    
    'ROW 9 "POWER COST PER KILOWATT HOUR"
    oPPTShape.Table.Cell(9, 2).Shape.TextFrame.TextRange.Text = Format(Cells(22, 4).Text, "$0.00") 'x = Row, y = Column
    oPPTShape.Table.Cell(9, 3).Shape.TextFrame.TextRange.Text = Format(Cells(22, 8).Text, "$0.00")
        
    ProgressStatus.ProgressBar1.Value = 50
    DoEvents
    
    'ROW 10 "TOTAL POWER COST PER ANNUM"
    oPPTShape.Table.Cell(10, 2).Shape.TextFrame.TextRange.Text = Format(Cells(26, 4).Text, "$#,##") 'x = Row, y = Column
    oPPTShape.Table.Cell(10, 3).Shape.TextFrame.TextRange.Text = Format(Cells(26, 8).Text, "$#,##")
    oPPTShape.Table.Cell(10, 4).Shape.TextFrame.TextRange.Text = Format(Cells(26, 12).Text, "$#,##")
    
    'ROW 11 "GREENHOUSE GAS EMISSIONS PER ANNUM"
    oPPTShape.Table.Cell(11, 2).Shape.TextFrame.TextRange.Text = Cells(24, 4).Text 'x = Row, y = Column
    oPPTShape.Table.Cell(11, 3).Shape.TextFrame.TextRange.Text = Cells(24, 8).Text
    oPPTShape.Table.Cell(11, 4).Shape.TextFrame.TextRange.Text = Cells(24, 12).Text
    
    ProgressStatus.ProgressBar1.Value = 60
    DoEvents
    
    'ROW 12 "TOTAL COST YEAR 1"
    oPPTShape.Table.Cell(12, 2).Shape.TextFrame.TextRange.Text = Format(Cells(28, 4).Text, "$#,##") 'x = Row, y = Column
    oPPTShape.Table.Cell(12, 3).Shape.TextFrame.TextRange.Text = Format(Cells(28, 8).Text, "$#,##")
    oPPTShape.Table.Cell(12, 4).Shape.TextFrame.TextRange.Text = Format(Cells(28, 12).Text, "$#,##")
    
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("TxtBlack")
    oPPTShape.TextFrame.TextRange = Format(ActiveSheet.Range("D30").Text, "#,##")
    
    ProgressStatus.ProgressBar1.Value = 70
    DoEvents
    
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("TxtROI")
    oPPTShape.TextFrame.TextRange = Format(ActiveSheet.Range("D31").Text, "Percent")
    
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("TxtIRR")
    oPPTShape.TextFrame.TextRange = Format(ActiveSheet.Range("D32").Text, "Fixed")
    
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("TxtIRRMonths")
    oPPTShape.TextFrame.TextRange = Format(ActiveSheet.Range("F32").Text, "Fixed")
         
    ProgressStatus.ProgressBar1.Value = 80
    DoEvents
         
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("TxtLights")
    oPPTShape.TextFrame.TextRange = Format(ActiveSheet.Range("D4").Text, "#,##")
    
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("TxtHours")
    oPPTShape.TextFrame.TextRange = ActiveSheet.Range("D5").Text
    
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("TxtDays")
    oPPTShape.TextFrame.TextRange = ActiveSheet.Range("D6").Text
            
    Set oPPTShape = Nothing
            
    'TEST IF MICROSOFT ADD-IN IS INSTALLED ON USERS COMPUTER ==>
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
    
        pdfName = ActiveWorkbook.Path & "\" & newName & ".pdf"
        
        FileFormatstr = "PDF Files (*.pdf), *.pdf"
                Fname = Application.GetSaveAsFilename(pdfName, filefilter:=FileFormatstr, _
                                                      Title:="Create PDF")
        oPPTFile.SaveAs FileName:=Fname, FileFormat:=ppSaveAsPDF
    Else
        MsgBox "You cannot run this script as you do not have the Export PDF add-in loaded on your system.", vbInformation
    End If
    
    ProgressStatus.ProgressBar1.Value = 90
    DoEvents
    
    'PERFORMING CLEANUP OF ALL FILES ==>
    oPPTFile.Close
    oPPTApp.Quit
          
    Set oPPTShape = Nothing
    Set oPPTFile = Nothing
    Set oPPTApp = Nothing
    
    ProgressStatus.ProgressBar1.Value = 100
    DoEvents
           
    Unload ProgressStatus
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
        
    MsgBox "Presentation Created", vbOKOnly + vbInformation
    
    ActiveSheet.Range("D30").Select
    
End Sub

Open in new window

0
creativefusion
Asked:
creativefusion
  • 2
1 Solution
 
philip m o'brienCommented:
CreativeFusion,
In line 157 you provide for one PDF file name and path, but in line 160 you are asking it to prompt for another (Fname). Is this actually what you want, or do you intend for it to use "pdfName" as the new file path and name?
If this is so you shouldn't ask for a new filename but instead should and change line 162 to read:
 
oPPTFile.SaveAs FileName:pdfName, FileFormat:=ppSaveAsPDF

Open in new window

and delete line 160.
Regards
0
 
creativefusionAuthor Commented:
Thanks heaps. Stupid mistake!!
0
 
philip m o'brienCommented:
Wouldn't worry, I make them all the time and call it learning ;-)
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now