Not Responding - Application hangs in VBA

[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

 

[Rod Gill]

Please note this group is closing soon, so the project.developer group is
preferred. However, where is the code failing? Press Ctrl+Break to get the
End or Debug dialog. Click Debug and tell us where the code is stuck.

You could also enter the following into the Immediate window then press
Enter.

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

Copy paste teh resultant string into an Access query's SQL window and
confirm teh SQL code is valid.

 

[Rick Williams]

Within your Do Until loop you need a MoveNext. That is where the code is
hanging - it is working on the first record over and over.
Hope this helps,
Rick Williams