Not Responding - Access hangs

[tiger]

Hi,

My application hangs in the below code, I am getting data from a recordeset
and the displaying the data in a PowerPoint that is generated from the
application....

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add

Set pptSld = pptPres.Slides.Add(1,ppLayoutText)

Dim rstAccomp As ADODB.Recordset
Set rstAccomp = New ADODB.Recordset

Dim strSQL As String

Dim StartDate As Date
Dim EndDate As Date

StartDate = Format$(Date,"Short Date")
EndDate = Format$(Date,"Short Date")

strSQL ="SELECT DISTINCT Accomplishment, DDate FROM tblAccomplishment WHERE
ProgramIpt = '" & SelectedIpt & "' AND DDate Between " & Format(StartDate,
"\#mm\/dd\/yyyy\#") & " AND " & Format(EndDate,"\#mm\/dd\/yyyy\#")


With rstAccomp
.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockPessimistic
if rstAccomp.BOF And rstAccomp.EOF Then
MsgBox "No DATA IN the recordset", vbCritical, Error
strText = "None"
Else
.MoveFirst
Do Until .EOF
strText = .Fields("Accomplishment") & vbTab & .Fields("DDate") & vbCrLf
Loop
End If
End With

rstAccomp.Close
Set rstAccomp = Nothing

With pptSld.Shapes(2).TextFrame.TextRange
..text = "Accomplishment: " & vbCrLf & vbTab & strText & vbCrLf

With .Font
..Name = "Arial"
..Bold = True
..Size = 13
End With
End With

pptApp.Activate
pptApp.Visible = True
pptPres.SlideShowSettings.Run

Set pptApp = Nothing
Set pptPres = Nothing

Application.Screen.MousePointer = 0