Stop an execution in a loop

[easycode]

Hi all,

I have an access form that calls a power point application and while access is generating all the slides i have a form displaying the number and some information regarding the slides in the same form at the bottom i have a Stop button that i would like it to stop the execution when someone clicks on it, but it does not work it doesn even let me click on it, it looks like the loop has the control of the whole application and does not respond when i click on the button, Here is the code. Any help is appreciated.
I am runnning on an Access and PPT 2003


Sub sendtoPPT()
On Error GoTo Err_sendtoPPT
Dim ppObj As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim rstcharts As ADODB.Recordset
Dim rstpath As ADODB.Recordset 'path to retrieve pot file for the ppt presentation
Dim fsql2 As String
Dim fsql As String, fform As String, ftitle As String, fname As String
Dim fslidenumber As Integer
Dim fpotpath As String
Dim rstmsg As ADODB.Recordset
Dim fdelaymessage As Integer
Dim fjump As Integer


' Open up an instance of Powerpoint.
Set ppObj = New PowerPoint.Application
Set ppPres = ppObj.Presentations.Add

Set rstcharts = New ADODB.Recordset
Set rstpath = New ADODB.Recordset 'recordset to retrieve the pot file
Set rstmsg = New ADODB.Recordset

fsql = "SELECT * FROM Charts order by Chartnumber"
fslidenumber = 0
fsql2 = "Select * from sysparam where code=2"

DoCmd.Echo True
DoCmd.Hourglass False

rstpath.Open fsql2, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
fpotpath = rstpath![fpath]
rstmsg.Open "Select * from msg", CurrentProject.Connection, adOpenDynamic, adLockOptimistic

fdelaymessage = 2

ppPres.ApplyTemplate fpotpath & "\bd.pot" 'Path where the bd design template is located at.
DoCmd.OpenForm "frmMessage", acNormal
Randomize ' Initialize random-number generator.
With ppPres
rstcharts.Open fsql, CurrentProject.Connection, adOpenDynamic, adLockReadOnly
rstcharts.MoveFirst
Do While Not rstcharts.EOF
fform = rstcharts![Chartform]
ftitle = rstcharts![Charttitle]
fname = rstcharts![Chartname]
fslidenumber = fslidenumber + 1
Set ppSlide = .Slides.Add(fslidenumber, ppLayoutTitleOnly)
With ppSlide
.Shapes(1).TextFrame.TextRange.Text = ftitle
.Shapes(1).Width = 650
.Shapes(1).Top = 30
.Shapes(1).Left = 30
.Shapes(1).Height = 40
.Shapes(1).TextFrame.TextRange.Font.Name = "Arial"
.Shapes(1).TextFrame.TextRange.Font.Size = 24
.Shapes(1).TextFrame.TextRange.Font.Shadow = msoFalse

'From Access
SysCmd acSysCmdSetStatus, "PPT Presentation is executing... " & fform
DoCmd.Echo True
fdelaymessage = fdelaymessage + 1
Forms("frmMessage").Controls("lblmessage").Caption = vbCrLf & "Executing " & fform
If (fdelaymessage Mod 4) = 0 Then 'if 0 display the message, if not does not display
fjump = (Int((Rnd * 99) + 1))
rstmsg.MoveFirst
rstmsg.Move fjump
Forms("frmMessage").Controls("lblmessage2").Caption = vbCrLf & rstmsg![Message]
End If
DoCmd.Echo False
DoCmd.OpenForm fform, acNormal
Forms(fform).Controls(fname).SetFocus
DoCmd.RunCommand acCmdCopy
'To PP
.Shapes.Paste
DoCmd.Close acForm, fform
End With
rstcharts.MoveNext
Loop
End With

DoCmd.Close acForm, "frmMessage"
Set rstcharts = Nothing
SysCmd acSysCmdClearStatus 'Clear the text in the status bar
' Make PowerPoint visible
ppObj.Visible = msoTrue

With ppSlide.SlideShowTransition
.AdvanceOnTime = msoTrue
.AdvanceTime = 1
End With

' Run the show.
ppPres.SlideShowSettings.Run
DoCmd.Echo True
DoCmd.Hourglass False
Set rstmsg = Nothing

 

[easycode]

i'm about to leave but i'll check the postings on monday morning

 

[PHV]

Use the DoEvents function inside the Loop.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[easycode]

Thank you PHV it worked!