Results 1 to 8 of 8
  1. 06-27-2017, 08:00 PM #1
    Canadiangal
    Canadiangal is offline Advanced Beginner
    Windows XP Access 2007
    Join Date
    Sep 2009
    Posts
    81

    Upgraded database needs a print preview prior to printing

    I have upgraded this survey database from Access 95 to 2010. I wanted to add a print preview to this code but I can't seem to get it to work. This isn't my code but copied over from the old database. I tried to add acPreviewReport to the code where previously acPreview was but nothing happened. The old database didn't show a preview either, but printed directly to the printer. I am pasting the code in and yes I realize that much is outdated but I'm not familiar enough with visual basic to redo it. Any insight would be appreciated regarding a print preview.
    Code:
     Private Sub Command13_Click()
  Dim db As Database
  Dim rsdata As Recordset, rstally As Recordset
  Dim rskey As Recordset, rstext As Recordset
  Dim Bdate As Date
  Dim Edate As Date
  Dim tst As String
  Dim txt As String, cnt As Integer
  Dim ans As Integer, j As Integer, k As Integer
  Dim xkey As Integer, xmonth As Integer, xquarter As Integer, xyear As Integer
  Dim keywant As Integer, qtrwant As Integer, yerwant As Integer
  Dim survey_form As Integer 'indicates which question set to use
  Dim qcvt(12) As Integer, flipit As Boolean
  Dim refcode As String
  Dim S(20) As Long
  Dim scores(20, 6) As Long
  Dim v1 As Long, v2 As Long
  Dim msg, style, response
  
    
  Set db = CurrentDb()
  Set rsdata = db.OpenRecordset("Data", dbOpenTable)
  rsdata.Index = "IDNmb"
  Set rstally = db.OpenRecordset("Tally", dbOpenTable)
  Set rskey = db.OpenRecordset("Types", dbOpenTable)
  rskey.Index = "Key"
  Set rstext = db.OpenRecordset("QText", dbOpenTable)
  rstext.Index = "RCode"
  qcvt(1) = 1
  qcvt(2) = 1
  qcvt(3) = 1
  qcvt(4) = 2
  qcvt(5) = 2
  qcvt(6) = 2
  qcvt(7) = 3
  qcvt(8) = 3
  qcvt(9) = 3
  qcvt(10) = 4
  qcvt(11) = 4
  qcvt(12) = 4
'--------------------
  rskey.MoveFirst
  Do While Not rskey.EOF
    keywant = rskey!Key
    survey_form = rskey!Key
    qtrwant = Forms!PreRep!TheQuarter
    yerwant = Forms!PreRep!TheYear
    Forms!Main!RpTitle = rskey!Descript & " Totals Report"
    GoSub DoTally
    msg = rskey!Descript & " - Print ?"
    style = vbYesNo + vbCritical + vbDefaultButton2
    response = MsgBox(msg, style)
    If response = vbYes Then    ' User chose Yes.
      DoCmd.OpenReport "Report1" ', acPreview
      DoCmd.OpenReport "Report2" ', acPreview
    End If
    rskey.MoveNext
  Loop
'--------------------
  rsdata.Close
  rstally.Close
  rskey.Close
  rstext.Close
Exit Sub
'=================================================
DoTally:
    DoCmd.SetWarnings False
      DoCmd.RunSQL "delete * from Tally;"
      For j = 1 To 20
      For k = 1 To 6
        scores(j, k) = 0
      Next k
      Next j
    DoCmd.SetWarnings True
    rsdata.MoveFirst
    Do While Not rsdata.EOF
      If Len(rsdata!Batch) = 7 Then
        xmonth = Val(Left(rsdata!Batch, 2))
        xquarter = qcvt(xmonth)
        If qtrwant = 5 Then xquarter = 5 'avz
        xyear = Val(Mid(rsdata!Batch, 4, 4))
        xkey = rsdata!Type
        'avz If keywant = 6 And xkey = 10 Then xkey = 6 'include Radiology in OP Services totals
      Else
        xquarter = 0
      End If
      If (xkey = keywant) And (xquarter = qtrwant) And (xyear = yerwant) Then
        Debug.Print Str(rsdata!IDNmb) & "--" & rsdata!Batch & "--" & Str(rsdata!Type)
        S(1) = Nz(rsdata!Q1)
        S(2) = Nz(rsdata!Q2)
        '---------
        If S(2) > 9 Then
        v1 = S(2)
        v2 = (v1 / 10)
        S(2) = v1 - (v2 * 10)
        End If
        '---------
        S(3) = Nz(rsdata!Q3)
        S(4) = Nz(rsdata!Q4)
        S(5) = Nz(rsdata!Q5)
        S(6) = Nz(rsdata!Q6)
        S(7) = Nz(rsdata!Q7)
        S(8) = Nz(rsdata!Q8)
        S(9) = Nz(rsdata!Q9)
        S(10) = Nz(rsdata!Q10)
        S(11) = Nz(rsdata!Q11)
        S(12) = Nz(rsdata!Q12)
        S(13) = Nz(rsdata!Q13)
        S(14) = Nz(rsdata!Q14)
        S(15) = Nz(rsdata!Q15)
        S(16) = Nz(rsdata!Q16)
        S(17) = Nz(rsdata!Q17)
        S(18) = Nz(rsdata!Q18)
        S(19) = Nz(rsdata!Q19)
        S(20) = Nz(rsdata!Q20)
        Debug.Print Str(rsdata!IDNmb) & "--" & rsdata!Batch & "--" & Str(rsdata!Type)
        For k = 1 To 20
          If Nz(S(k), 0) > 0 Then
          scores(k, S(k)) = scores(k, S(k)) + 1
          scores(k, 6) = scores(k, 6) + 1
          End If
        Next k
      End If
    rsdata.MoveNext
    Loop
    '--------------
    'Debug.Print "Check Point Alpha"
    For k = 1 To 20
      rstally.AddNew
      rstally!SurveyID = 1
      rstally!QNmb = k
      refcode = Format(survey_form, "00") & Format(k, "00")
      'Debug.Print refcode
      rstally!RCode = refcode
      rstext.Seek "=", refcode
      If rstext.NoMatch Then
        flipit = False
      Else
        flipit = rstext!Flip
      End If
      If flipit = True Then
        rstally!VeryGood = scores(k, 1)
        rstally!Good = scores(k, 2)
        rstally!Fair = scores(k, 3)
        rstally!Poor = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!VeryGoodPct = scores(k, 1) / scores(k, 6)
          rstally!GoodPct = scores(k, 2) / scores(k, 6)
          rstally!FairPct = scores(k, 3) / scores(k, 6)
          rstally!PoorPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      Else
        rstally!Poor = scores(k, 1)
        rstally!Fair = scores(k, 2)
        rstally!Good = scores(k, 3)
        rstally!VeryGood = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!PoorPct = scores(k, 1) / scores(k, 6)
          rstally!FairPct = scores(k, 2) / scores(k, 6)
          rstally!GoodPct = scores(k, 3) / scores(k, 6)
          rstally!VeryGoodPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      End If
      rstally.Update
    Next k
'--------------
  Return
    
End Sub
Private Sub Command14_Click()
DoCmd.Close
End Sub
Private Sub Command17_Click()
  Dim db As Database
  Dim rsdata As Recordset, rstally As Recordset
  Dim rskey As Recordset, rstext As Recordset
  Dim Bdate As Date
  Dim Edate As Date
  Dim tst As String
  Dim txt As String, cnt As Integer
  Dim ans As Integer, j As Integer, k As Integer
  Dim xkey As String, xmonth As Integer, xquarter As Integer, xyear As Integer
  Dim keywant As String, qtrwant As Integer, yerwant As Integer
  Dim survey_form As Integer 'indicates which question set to use
  Dim qcvt(12) As Integer
  Dim btch As String
  Dim S(20) As Long
  Dim v1 As Long, v2 As Long
  Dim scores(20, 6) As Long
  Dim flipit As Boolean, refcode As String
  Dim msg, style, response
  Dim Trigger As Boolean '(avz 2012)
  Set db = CurrentDb()
  Set rsdata = db.OpenRecordset("Data", dbOpenTable)
  rsdata.Index = "IDNmb"
  Set rstally = db.OpenRecordset("Tally", dbOpenTable)
  Set rskey = db.OpenRecordset("Providers", dbOpenTable)
  rskey.Index = "RecNmb"
  Set rstext = db.OpenRecordset("QText", dbOpenTable)
  rstext.Index = "RCode"
  qcvt(1) = 1
  qcvt(2) = 1
  qcvt(3) = 1
  qcvt(4) = 2
  qcvt(5) = 2
  qcvt(6) = 2
  qcvt(7) = 3
  qcvt(8) = 3
  qcvt(9) = 3
  qcvt(10) = 4
  qcvt(11) = 4
  qcvt(12) = 4
'--------------------
  rskey.MoveFirst
  Do While Not rskey.EOF
    keywant = rskey!Key
    survey_form = 2 'Clinic Survey Form
    qtrwant = Forms!PreRep!TheQuarter
    yerwant = Forms!PreRep!TheYear
    Forms!Main!RpTitle = "Clinic Survey - " & rskey!RepName
    GoSub DoTally
    msg = rskey!Name & " - Print ?"
    style = vbYesNo + vbCritical + vbDefaultButton2
    response = MsgBox(msg, style)
    If response = vbYes Then    ' User chose Yes.
      DoCmd.OpenReport "Report1" ', acPreview
      DoCmd.OpenReport "Report2" ', acPreview
    End If
    rskey.MoveNext
  Loop
'--------------------
  rsdata.Close
  rstally.Close
  rskey.Close
  rstext.Close
Exit Sub
'=================================================
DoTally:
    DoCmd.SetWarnings False
    '(disabled 3/23/12)
    'If qtrwant = 5 Then
      'xkey = keywant
      'xquarter = qtrwant
      'xyear = yerwant
      'End If
      '---------------
      DoCmd.RunSQL "delete * from Tally;"
      For j = 1 To 20
      For k = 1 To 6
        scores(j, k) = 0
      Next k
      Next j
    DoCmd.SetWarnings True
    rsdata.MoveFirst
    Do While Not rsdata.EOF
      If Len(rsdata!Batch) = 7 Then
        xmonth = Val(Left(rsdata!Batch, 2))
        xquarter = qcvt(xmonth)
        xyear = Val(Mid(rsdata!Batch, 4, 4))
        xkey = Nz(rsdata!Provider, " ")
      Else
        xquarter = 0
      End If
      '----- added (3/23/2012) -----
      If qtrwant = 5 Then xquarter = 5
      '------------------
      If (xkey = keywant) And (xquarter = qtrwant) And (xyear = yerwant) Then
        S(1) = Nz(rsdata!Q1)
        S(2) = Nz(rsdata!Q2)
        '---------
        If S(2) > 9 Then
        v1 = S(2)
        v2 = (v1 / 10)
        S(2) = v1 - (v2 * 10)
        End If
        '---------
        S(3) = Nz(rsdata!Q3)
        S(4) = Nz(rsdata!Q4)
        S(5) = Nz(rsdata!Q5)
        S(6) = Nz(rsdata!Q6)
        S(7) = Nz(rsdata!Q7)
        S(8) = Nz(rsdata!Q8)
        S(9) = Nz(rsdata!Q9)
        S(10) = Nz(rsdata!Q10)
        S(11) = Nz(rsdata!Q11)
        S(12) = Nz(rsdata!Q12)
        S(13) = Nz(rsdata!Q13)
        S(14) = Nz(rsdata!Q14)
        S(15) = Nz(rsdata!Q15)
        S(16) = Nz(rsdata!Q16)
        S(17) = Nz(rsdata!Q17)
        S(18) = Nz(rsdata!Q18)
        S(19) = Nz(rsdata!Q19)
        S(20) = Nz(rsdata!Q20)
        For k = 1 To 20
          If Nz(S(k), 0) > 0 Then
          scores(k, S(k)) = scores(k, S(k)) + 1
          scores(k, 6) = scores(k, 6) + 1
          End If
        Next k
      End If
    rsdata.MoveNext
    Loop
    '--------------
    For k = 1 To 20
      rstally.AddNew
      rstally!SurveyID = 1
      rstally!QNmb = k
      refcode = Format(survey_form, "00") & Format(k, "00")
      rstally!RCode = refcode
      rstext.Seek "=", refcode
      If rstext.NoMatch Then
        flipit = False
      Else
        flipit = rstext!Flip
      End If
      If flipit = True Then
        rstally!VeryGood = scores(k, 1)
        rstally!Good = scores(k, 2)
        rstally!Fair = scores(k, 3)
        rstally!Poor = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!VeryGoodPct = scores(k, 1) / scores(k, 6)
          rstally!GoodPct = scores(k, 2) / scores(k, 6)
          rstally!FairPct = scores(k, 3) / scores(k, 6)
          rstally!PoorPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      Else
        rstally!Poor = scores(k, 1)
        rstally!Fair = scores(k, 2)
        rstally!Good = scores(k, 3)
        rstally!VeryGood = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!PoorPct = scores(k, 1) / scores(k, 6)
          rstally!FairPct = scores(k, 2) / scores(k, 6)
          rstally!GoodPct = scores(k, 3) / scores(k, 6)
          rstally!VeryGoodPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      End If
      rstally.Update
    Next k
'--------------
  Return
End Sub
 
Private Sub Command18_Click()
  Dim db As Database
  Dim rsdata As Recordset, rstally As Recordset
  Dim rskey As Recordset, rstext As Recordset
  Dim Bdate As Date
  Dim Edate As Date
  Dim tst As String
  Dim atch As String
  Dim txt As String, cnt As Integer
  Dim ans As Integer, j As Integer, k As Integer
  Dim xkey As String, xmonth As Integer, xquarter As Integer, xyear As Integer
  Dim xtype As Integer
  Dim keywant As String, qtrwant As Integer, yerwant As Integer
  Dim survey_form As Integer 'indicates which question set to use
  Dim qcvt(12) As Integer
  Dim thebatch As String
  Dim S(20), btch As String
  Dim scores(20, 6) As Long
  Dim flipit As Boolean, refcode As String
  Dim msg, style, response
  
  Set db = CurrentDb()
  Set rsdata = db.OpenRecordset("Data", dbOpenTable)
  rsdata.Index = "IDNmb"
  Set rstally = db.OpenRecordset("Tally", dbOpenTable)
  Set rskey = db.OpenRecordset("OPServices", dbOpenTable)
  rskey.Index = "RecNmb"
  Set rstext = db.OpenRecordset("QText", dbOpenTable)
  rstext.Index = "RCode"
  qcvt(1) = 1
  qcvt(2) = 1
  qcvt(3) = 1
  qcvt(4) = 2
  qcvt(5) = 2
  qcvt(6) = 2
  qcvt(7) = 3
  qcvt(8) = 3
  qcvt(9) = 3
  qcvt(10) = 4
  qcvt(11) = 4
  qcvt(12) = 4
'--------------------
  rskey.MoveFirst
  Do While Not rskey.EOF
    keywant = rskey!Key
    survey_form = 10
    qtrwant = Forms!PreRep!TheQuarter
    yerwant = Forms!PreRep!TheYear
    'rstally!Abatch = rskey!Batch
    Forms!Main!RpTitle = "Ancillary Services - " & rskey!Name
    GoSub DoTally
    msg = rskey!Name & " - Print ?"
    style = vbYesNo + vbCritical + vbDefaultButton2
    response = MsgBox(msg, style)
    If response = vbYes Then    ' User chose Yes.
      DoCmd.OpenReport "Report1" ', acPreview
      DoCmd.OpenReport "Report2" ', acPreview
    End If
    rskey.MoveNext
  Loop
'--------------------
  rsdata.Close
  rstally.Close
  rskey.Close
  rstext.Close
Exit Sub
'=================================================
DoTally:
    DoCmd.SetWarnings False
      DoCmd.RunSQL "delete * from Tally;"
      For j = 1 To 20
      For k = 1 To 6
        scores(j, k) = 0
      Next k
      Next j
    DoCmd.SetWarnings True
    rsdata.MoveFirst
    Do While Not rsdata.EOF
      If Len(rsdata!Batch) = 7 Then
        xmonth = Val(Left(rsdata!Batch, 2))
        xquarter = qcvt(xmonth)
        
        If qtrwant = 5 Then xquarter = 5 'avz
        
        xyear = Val(Mid(rsdata!Batch, 4, 4))
        xtype = Nz(rsdata!Type, " ")
        xkey = Nz(rsdata!Service, " ")
      Else
        xquarter = 0
      End If
      If (xtype = 10) And (xkey = keywant) And (xquarter = qtrwant) And (xyear = yerwant) Then
        S(1) = rsdata!Q1
        S(2) = rsdata!Q2
        S(3) = rsdata!Q3
        S(4) = rsdata!Q4
        S(5) = rsdata!Q5
        S(6) = rsdata!Q6
        S(7) = rsdata!Q7
        S(8) = rsdata!Q8
        S(9) = rsdata!Q9
        S(10) = rsdata!Q10
        S(11) = rsdata!Q11
        S(12) = rsdata!Q12
        S(13) = rsdata!Q13
        S(14) = rsdata!Q14
        S(15) = rsdata!Q15
        S(16) = rsdata!Q16
        S(17) = rsdata!Q17
        S(18) = rsdata!Q18
        S(19) = rsdata!Q19
        S(20) = rsdata!Q20
        For k = 1 To 20
          If Nz(S(k), 0) > 0 Then
          scores(k, S(k)) = scores(k, S(k)) + 1
          scores(k, 6) = scores(k, 6) + 1
          End If
        Next k
      End If
    rsdata.MoveNext
    Loop
    '--------------
    For k = 1 To 20
      rstally.AddNew
      'rstally!tbatch = thebatch 'avz
      rstally!SurveyID = 1
      rstally!QNmb = k
      refcode = Format(survey_form, "00") & Format(k, "00")
      rstally!RCode = refcode
      rstext.Seek "=", refcode
      If rstext.NoMatch Then
        flipit = False
      Else
        flipit = rstext!Flip
      End If
      If flipit = True Then
        rstally!VeryGood = scores(k, 1)
        rstally!Good = scores(k, 2)
        rstally!Fair = scores(k, 3)
        rstally!Poor = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!VeryGoodPct = scores(k, 1) / scores(k, 6)
          rstally!GoodPct = scores(k, 2) / scores(k, 6)
          rstally!FairPct = scores(k, 3) / scores(k, 6)
          rstally!PoorPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      Else
        rstally!Poor = scores(k, 1)
        rstally!Fair = scores(k, 2)
        rstally!Good = scores(k, 3)
        rstally!VeryGood = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!PoorPct = scores(k, 1) / scores(k, 6)
          rstally!FairPct = scores(k, 2) / scores(k, 6)
          rstally!GoodPct = scores(k, 3) / scores(k, 6)
          rstally!VeryGoodPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      End If
      rstally.Update
    Next k
'--------------
  Return
End Sub
Private Sub Command19_Click()
Dim db As Database
  Dim rsdata As Recordset, rstally As Recordset
  Dim rskey As Recordset, rstext As Recordset
  Dim Bdate As Date
  Dim Edate As Date
  Dim tst As String
  Dim txt As String, cnt As Integer
  Dim ans As Integer, j As Integer, k As Integer
  Dim xkey As String, xmonth As Integer, xquarter As Integer, xyear As Integer
  Dim xtype As Integer
  Dim keywant As String, qtrwant As Integer, yerwant As Integer
  Dim survey_form As Integer 'indicates which question set to use
  Dim qcvt(12) As Integer
  Dim S(20), btch As String
  Dim scores(20, 6) As Long
  Dim flipit As Boolean, refcode As String
  Dim msg, style, response
  
  Set db = CurrentDb()
  Set rsdata = db.OpenRecordset("Data", dbOpenTable)
  rsdata.Index = "IDNmb"
  Set rstally = db.OpenRecordset("Tally", dbOpenTable)
  Set rskey = db.OpenRecordset("OPProviders", dbOpenTable)
  rskey.Index = "RecNmb"
  Set rstext = db.OpenRecordset("QText", dbOpenTable)
  rstext.Index = "RCode"
  qcvt(1) = 1
  qcvt(2) = 1
  qcvt(3) = 1
  qcvt(4) = 2
  qcvt(5) = 2
  qcvt(6) = 2
  qcvt(7) = 3
  qcvt(8) = 3
  qcvt(9) = 3
  qcvt(10) = 4
  qcvt(11) = 4
  qcvt(12) = 4
'--------------------
  rskey.MoveFirst
  Do While Not rskey.EOF
    keywant = rskey!Key
    survey_form = 3 'Outpatient Dept Form
    qtrwant = Forms!PreRep!TheQuarter
    yerwant = Forms!PreRep!TheYear
    Forms!Main!RpTitle = "Outpatient Providers - " & rskey!Name
    GoSub DoTally
    msg = rskey!Name & " - Print ?"
    style = vbYesNo + vbCritical + vbDefaultButton2
    response = MsgBox(msg, style)
    If response = vbYes Then    ' User chose Yes.
      DoCmd.OpenReport "Report1" ', acPreview
      DoCmd.OpenReport "Report2" ', acPreview
    End If
    rskey.MoveNext
  Loop
'--------------------
  rsdata.Close
  rstally.Close
  rskey.Close
  rstext.Close
Exit Sub
'=================================================
DoTally:
    DoCmd.SetWarnings False
      DoCmd.RunSQL "delete * from Tally;"
      For j = 1 To 20
      For k = 1 To 6
        scores(j, k) = 0
      Next k
      Next j
    DoCmd.SetWarnings True
    rsdata.MoveFirst
    Do While Not rsdata.EOF
      If Len(rsdata!Batch) = 7 Then
        xmonth = Val(Left(rsdata!Batch, 2))
        xquarter = qcvt(xmonth)
        xyear = Val(Mid(rsdata!Batch, 4, 4))
        xtype = Nz(rsdata!Type, " ")
        xkey = Nz(rsdata!Specialist, " ")
      Else
        xquarter = 0
      End If
      If (xtype = 3) And (xkey = keywant) And (xquarter = qtrwant) And (xyear = yerwant) Then
        S(1) = rsdata!Q1
        S(2) = rsdata!Q2
        S(3) = rsdata!Q3
        S(4) = rsdata!Q4
        S(5) = rsdata!Q5
        S(6) = rsdata!Q6
        S(7) = rsdata!Q7
        S(8) = rsdata!Q8
        S(9) = rsdata!Q9
        S(10) = rsdata!Q10
        S(11) = rsdata!Q11
        S(12) = rsdata!Q12
        S(13) = rsdata!Q13
        S(14) = rsdata!Q14
        S(15) = rsdata!Q15
        S(16) = rsdata!Q16
        S(17) = rsdata!Q17
        S(18) = rsdata!Q18
        S(19) = rsdata!Q19
        S(20) = rsdata!Q20
        For k = 1 To 20
          If Nz(S(k), 0) > 0 Then
          scores(k, S(k)) = scores(k, S(k)) + 1
          scores(k, 6) = scores(k, 6) + 1
          End If
        Next k
      End If
    rsdata.MoveNext
    Loop
    '--------------
    For k = 1 To 20
      rstally.AddNew
      rstally!SurveyID = 1
      rstally!QNmb = k
      refcode = Format(survey_form, "00") & Format(k, "00")
      rstally!RCode = refcode
      rstext.Seek "=", refcode
      If rstext.NoMatch Then
        flipit = False
      Else
        flipit = rstext!Flip
      End If
      If flipit = True Then
        rstally!VeryGood = scores(k, 1)
        rstally!Good = scores(k, 2)
        rstally!Fair = scores(k, 3)
        rstally!Poor = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!VeryGoodPct = scores(k, 1) / scores(k, 6)
          rstally!GoodPct = scores(k, 2) / scores(k, 6)
          rstally!FairPct = scores(k, 3) / scores(k, 6)
          rstally!PoorPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      Else
        rstally!Poor = scores(k, 1)
        rstally!Fair = scores(k, 2)
        rstally!Good = scores(k, 3)
        rstally!VeryGood = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!PoorPct = scores(k, 1) / scores(k, 6)
          rstally!FairPct = scores(k, 2) / scores(k, 6)
          rstally!GoodPct = scores(k, 3) / scores(k, 6)
          rstally!VeryGoodPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      End If
      rstally.Update
    Next k
'--------------
  Return
End Sub
Private Sub Command20_Click()
  Dim db As Database
  Dim rsdata As Recordset, rstally As Recordset
  Dim rskey As Recordset, rstext As Recordset
  Dim Bdate As Date
  Dim Edate As Date
  Dim tst As String
  Dim txt As String, cnt As Integer
  Dim ans As Integer, j As Integer, k As Integer
  Dim xkey As String, xmonth As Integer, xquarter As Integer, xyear As Integer
  Dim xtype As Integer
  Dim keywant As String, qtrwant As Integer, yerwant As Integer
  Dim survey_form As Integer 'indicates which question set to use
  Dim qcvt(12) As Integer
  Dim btch As String
  Dim S(20) As Long
  Dim scores(20, 6) As Long
  Dim v1 As Long, v2 As Long
  Dim flipit As Boolean, refcode As String
  Dim msg, style, response
  
  Set db = CurrentDb()
  Set rsdata = db.OpenRecordset("Data", dbOpenTable)
  rsdata.Index = "IDNmb"
  Set rstally = db.OpenRecordset("Tally", dbOpenTable)
  Set rskey = db.OpenRecordset("Clinics", dbOpenTable)
  rskey.Index = "RecNmb"
  Set rstext = db.OpenRecordset("QText", dbOpenTable)
  rstext.Index = "RCode"
  qcvt(1) = 1
  qcvt(2) = 1
  qcvt(3) = 1
  qcvt(4) = 2
  qcvt(5) = 2
  qcvt(6) = 2
  qcvt(7) = 3
  qcvt(8) = 3
  qcvt(9) = 3
  qcvt(10) = 4
  qcvt(11) = 4
  qcvt(12) = 4
'--------------------
  rskey.MoveFirst
  Do While Not rskey.EOF
    keywant = rskey!Key
    survey_form = 2 'Clinic Survey Form
    qtrwant = Forms!PreRep!TheQuarter
    yerwant = Forms!PreRep!TheYear
    Forms!Main!RpTitle = "Clinic Survey - " & rskey!Name
    GoSub DoTally
    msg = rskey!Name & " - Print ?"
    style = vbYesNo + vbCritical + vbDefaultButton2
    response = MsgBox(msg, style)
    If response = vbYes Then    ' User chose Yes.
      DoCmd.OpenReport "Report1" ', acPreview
      DoCmd.OpenReport "Report2" ', acPreview
    End If
    rskey.MoveNext
  Loop
'--------------------
  rsdata.Close
  rstally.Close
  rskey.Close
  rstext.Close
Exit Sub
'=================================================
DoTally:
    DoCmd.SetWarnings False
      DoCmd.RunSQL "delete * from Tally;"
      For j = 1 To 20
      For k = 1 To 6
        scores(j, k) = 0
      Next k
      Next j
    DoCmd.SetWarnings True
    rsdata.MoveFirst
    Do While Not rsdata.EOF
      If Len(rsdata!Batch) = 7 Then
        xmonth = Val(Left(rsdata!Batch, 2))
        xquarter = qcvt(xmonth)
        xyear = Val(Mid(rsdata!Batch, 4, 4))
        xtype = Nz(rsdata!Type, " ")
        xkey = Nz(rsdata!Clinic, " ")
      Else
        xquarter = 0
      End If
      If (xtype = 2) And (xkey = keywant) And (xquarter = qtrwant) And (xyear = yerwant) Then
        S(1) = Nz(rsdata!Q1)
        S(2) = Nz(rsdata!Q2)
        '---------
        If S(2) > 9 Then
        v1 = S(2)
        v2 = (v1 / 10)
        S(2) = v1 - (v2 * 10)
        End If
        '---------
        S(3) = Nz(rsdata!Q3)
        S(4) = Nz(rsdata!Q4)
        S(5) = Nz(rsdata!Q5)
        S(6) = Nz(rsdata!Q6)
        S(7) = Nz(rsdata!Q7)
        S(8) = Nz(rsdata!Q8)
        S(9) = Nz(rsdata!Q9)
        S(10) = Nz(rsdata!Q10)
        S(11) = Nz(rsdata!Q11)
        S(12) = Nz(rsdata!Q12)
        S(13) = Nz(rsdata!Q13)
        S(14) = Nz(rsdata!Q14)
        S(15) = Nz(rsdata!Q15)
        S(16) = Nz(rsdata!Q16)
        S(17) = Nz(rsdata!Q17)
        S(18) = Nz(rsdata!Q18)
        S(19) = Nz(rsdata!Q19)
        S(20) = Nz(rsdata!Q20)
        For k = 1 To 20
          If Nz(S(k), 0) > 0 Then
          scores(k, S(k)) = scores(k, S(k)) + 1
          scores(k, 6) = scores(k, 6) + 1
          End If
        Next k
      End If
    rsdata.MoveNext
    Loop
    '--------------
    For k = 1 To 20
      rstally.AddNew
      rstally!SurveyID = 1
      rstally!QNmb = k
      refcode = Format(survey_form, "00") & Format(k, "00")
      rstally!RCode = refcode
      rstext.Seek "=", refcode
      If rstext.NoMatch Then
        flipit = False
      Else
        flipit = rstext!Flip
      End If
      If flipit = True Then
        rstally!VeryGood = scores(k, 1)
        rstally!Good = scores(k, 2)
        rstally!Fair = scores(k, 3)
        rstally!Poor = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!VeryGoodPct = scores(k, 1) / scores(k, 6)
          rstally!GoodPct = scores(k, 2) / scores(k, 6)
          rstally!FairPct = scores(k, 3) / scores(k, 6)
          rstally!PoorPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      Else
        rstally!Poor = scores(k, 1)
        rstally!Fair = scores(k, 2)
        rstally!Good = scores(k, 3)
        rstally!VeryGood = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!PoorPct = scores(k, 1) / scores(k, 6)
          rstally!FairPct = scores(k, 2) / scores(k, 6)
          rstally!GoodPct = scores(k, 3) / scores(k, 6)
          rstally!VeryGoodPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      End If
      rstally.Update
    Next k
'--------------
  Return
End Sub
Private Sub Command21_Click()
Dim db As Database
  Dim rsdata As Recordset, rstally As Recordset
  Dim rskey As Recordset, rstext As Recordset
  Dim Bdate As Date
  Dim Edate As Date
  Dim tst As String
  Dim txt As String, cnt As Integer
  Dim ans As Integer, j As Integer, k As Integer
  Dim xkey As String, xmonth As Integer, xquarter As Integer, xyear As Integer
  Dim keywant As String, qtrwant As Integer, yerwant As Integer
  Dim survey_form As Integer 'indicates which question set to use
  Dim qcvt(12) As Integer
  Dim S(20), btch As String
  Dim scores(20, 6) As Long
  Dim flipit As Boolean, refcode As String
  Dim msg, style, response
    
  Set db = CurrentDb()
  Set rsdata = db.OpenRecordset("Data", dbOpenTable)
  rsdata.Index = "IDNmb"
  Set rstally = db.OpenRecordset("Tally", dbOpenTable)
  Set rskey = db.OpenRecordset("NWSProviders", dbOpenTable)
  rskey.Index = "RecNmb"
  Set rstext = db.OpenRecordset("QText", dbOpenTable)
  rstext.Index = "RCode"
  qcvt(1) = 1
  qcvt(2) = 1
  qcvt(3) = 1
  qcvt(4) = 2
  qcvt(5) = 2
  qcvt(6) = 2
  qcvt(7) = 3
  qcvt(8) = 3
  qcvt(9) = 3
  qcvt(10) = 4
  qcvt(11) = 4
  qcvt(12) = 4
'--------------------
  rskey.MoveFirst
  Do While Not rskey.EOF
    keywant = rskey!Key
    survey_form = 12 'NW Surgery Providers Form
    qtrwant = Forms!PreRep!TheQuarter
    yerwant = Forms!PreRep!TheYear
    Forms!Main!RpTitle = "NW Surgery Survey - " & rskey!Name
    GoSub DoTally
    msg = rskey!Name & " - Print ?"
    style = vbYesNo + vbCritical + vbDefaultButton2
    response = MsgBox(msg, style)
    If response = vbYes Then    ' User chose Yes.
      DoCmd.OpenReport "Report1" ', acPreview
      DoCmd.OpenReport "Report2" ', acPreview
    End If
    rskey.MoveNext
  Loop
'--------------------
  rsdata.Close
  rstally.Close
  rskey.Close
  rstext.Close
Exit Sub
'=================================================
DoTally:
    DoCmd.SetWarnings False
      DoCmd.RunSQL "delete * from Tally;"
      For j = 1 To 20
      For k = 1 To 6
        scores(j, k) = 0
      Next k
      Next j
    DoCmd.SetWarnings True
    rsdata.MoveFirst
    Do While Not rsdata.EOF
      If Len(rsdata!Batch) = 7 Then
        xmonth = Val(Left(rsdata!Batch, 2))
        xquarter = qcvt(xmonth)
        xyear = Val(Mid(rsdata!Batch, 4, 4))
        xkey = Nz(rsdata!NWSProvider, " ")
      Else
        xquarter = 0
      End If
      If (xkey = keywant) And (xquarter = qtrwant) And (xyear = yerwant) Then
        S(1) = rsdata!Q1
        S(2) = rsdata!Q2
        S(3) = rsdata!Q3
        S(4) = rsdata!Q4
        S(5) = rsdata!Q5
        S(6) = rsdata!Q6
        S(7) = rsdata!Q7
        S(8) = rsdata!Q8
        S(9) = rsdata!Q9
        S(10) = rsdata!Q10
        S(11) = rsdata!Q11
        S(12) = rsdata!Q12
        S(13) = rsdata!Q13
        S(14) = rsdata!Q14
        S(15) = rsdata!Q15
        S(16) = rsdata!Q16
        S(17) = rsdata!Q17
        S(18) = rsdata!Q18
        S(19) = rsdata!Q19
        S(20) = rsdata!Q20
        For k = 1 To 20
          If Nz(S(k), 1) > 0 Then
          scores(k, S(k)) = scores(k, S(k)) + 1
          scores(k, 6) = scores(k, 6) + 1
          End If
        Next k
      End If
    rsdata.MoveNext
    Loop
    '--------------
    For k = 1 To 20
      rstally.AddNew
      rstally!SurveyID = 1
      rstally!QNmb = k
      refcode = Format(survey_form, "00") & Format(k, "00")
      rstally!RCode = refcode
      rstext.Seek "=", refcode
      If rstext.NoMatch Then
        flipit = False
      Else
        flipit = rstext!Flip
      End If
      If flipit = True Then
        rstally!VeryGood = scores(k, 1)
        rstally!Good = scores(k, 2)
        rstally!Fair = scores(k, 3)
        rstally!Poor = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!VeryGoodPct = scores(k, 1) / scores(k, 6)
          rstally!GoodPct = scores(k, 2) / scores(k, 6)
          rstally!FairPct = scores(k, 3) / scores(k, 6)
          rstally!PoorPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      Else
        rstally!Poor = scores(k, 1)
        rstally!Fair = scores(k, 2)
        rstally!Good = scores(k, 3)
        rstally!VeryGood = scores(k, 4)
        rstally!Excellent = scores(k, 5)
        rstally!Total = scores(k, 6)
        If scores(k, 6) > 0 Then
          rstally!PoorPct = scores(k, 1) / scores(k, 6)
          rstally!FairPct = scores(k, 2) / scores(k, 6)
          rstally!GoodPct = scores(k, 3) / scores(k, 6)
          rstally!VeryGoodPct = scores(k, 4) / scores(k, 6)
          rstally!ExcellentPct = scores(k, 5) / scores(k, 6)
        End If
      End If
      rstally.Update
    Next k
'--------------
  Return
End Sub

    Reply With Quote Reply With Quote
  2. 06-27-2017, 08:31 PM #2
    Micron
    Micron is offline Virtually Inert Person
    Windows 7 32bit Access 2007
    Join Date
    Jun 2014
    Location
    Ontario, Canada
    Posts
    12,793
    I stopped when I saw the single quote DoCmd.OpenReport "Report1" ', acPreview
    The syntax is Docmd.OpenReport(ReportName, View, FilterName, WhereCondition, WindowMode, OpenArgs)
    the parameter you want is acViewPreview, not acPreview, thus

    DoCmd.OpenReport "Report1", acViewPreview
    Here's more info on the subject
    http://www.blueclaw-db.com/docmd_openreport.htm
    The more we hear silence, the more we begin to think about our value in this universe.
    Paraphrase of Professor Brian Cox.
    Reply With Quote Reply With Quote
  3. 06-27-2017, 08:39 PM #3
    Micron
    Micron is offline Virtually Inert Person
    Windows 7 32bit Access 2007
    Join Date
    Jun 2014
    Location
    Ontario, Canada
    Posts
    12,793
    Consider reclaiming the memory space allocated to these recordsets. Closing them is only half of it.

    Set rsdata = Nothing
    Set rstally = Nothing
    Set rskey = Nothing
    Set rstext = Nothing
    The more we hear silence, the more we begin to think about our value in this universe.
    Paraphrase of Professor Brian Cox.
    Reply With Quote Reply With Quote
  4. 06-27-2017, 08:43 PM #4
    ssanfu
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    Whew... That is a lot of code!

    OK, try this. In a COPY of the dB, everywhere you want to preview the report, change the command
    FROM
    Code:
                DoCmd.OpenReport "Report1"    ', acPreview
            DoCmd.OpenReport "Report2"    ', acPreview
    TO
    Code:
                DoCmd.OpenReport "Report1", acViewPreview
            DoCmd.OpenReport "Report2", acViewPreview
    I would try it in one sub before changing it everywhere....


    ================================================== =====

    Other changes:

    Wherever you have
    Code:
        Dim db As Database
    Dim rsdata As Recordset, rstally As Recordset
    Dim rskey As Recordset, rstext As Recordset
    I would change it to
    Code:
        Dim db As DAO.Database
    Dim rsdata As DAO.Recordset, rstally As DAO.Recordset
    Dim rskey As DAO.Recordset, rstext As DAO.Recordset

    And where you see
    Code:
        rsdata.Close
    rstally.Close
    rskey.Close
    rstext.Close
    I would add these lines
    Code:
        rsdata.Close
    rstally.Close
    rskey.Close
    rstext.Close

    Set rsdata = Nothing
    Set rstally = Nothing
    Set rskey = Nothing
    Set rstext = Nothing
    Set db  = Nothing


    Edit: Drat!! Beat by Micron... AGAIN!!!
    Reply With Quote Reply With Quote
  5. 06-27-2017, 09:42 PM #5
    Micron
    Micron is offline Virtually Inert Person
    Windows 7 32bit Access 2007
    Join Date
    Jun 2014
    Location
    Ontario, Canada
    Posts
    12,793
    Turnabout is fair play
    Good catch on the Set db = Nothing
    If it were me, and I advised OP to specify DAO as the reference library, I'd warn about ensuring the library was referenced. If not, it will likely cause an error.
    Just sayin'.
    Reply With Quote Reply With Quote
  6. 06-27-2017, 10:28 PM #6
    Canadiangal
    Canadiangal is offline Advanced Beginner
    Windows XP Access 2007
    Join Date
    Sep 2009
    Posts
    81
    Thank you all for your help!
    Reply With Quote Reply With Quote
  7. 06-28-2017, 05:47 AM #7
    orange's Avatar
    orange
    orange is offline Moderator
    Windows 10 Access 2010 32bit
    Join Date
    Sep 2009
    Location
    Ottawa, Ontario, Canada; West Palm Beach FL
    Posts
    16,722
    In addition to comments/advice from Steve and Micron, I would also suggest:

    Change this construct
    Code:
    DoCmd.SetWarnings False
      DoCmd.RunSQL "delete * from Tally;"
....
      
DoCmd.SetWarnings True
    Change the
    "delete * from Tally;" to a variable

    eg : Dim Delsql as string
    Delsql = "delete * from Tally;"

    Then use
    Code:
    db.execute Delsql,dbFailOnError
    this will eliminate the need for SetWarnings, and will give an error
    if a failure occurs.

    I don't know that this will improve anything other than removing
    some of the annoyance of SetWarnings.

    I haven't looked at the logic.

    This
    Code:
    Dim S(20), btch As String
    will
    Dim S(20) as Variant and btch as String

    Nicely indented code, and use of arrays.

    Good luck with the project.
    AccessFunctions_SyntaxAndExamples TechontheNet
    M$oftVBA Function Details
    Debugging VBA and Error Handling
    Links to articles re Database Planning and Design
    DataPig Videos Revived DataPig Queries
    DataPig Form Basics
    Reply With Quote Reply With Quote
  8. 06-28-2017, 03:23 PM #8
    ssanfu
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    And I would rename the buttons/code (a real annoyance to me)
    FROM
    Code:
    Private Sub Command14_Click()
    DoCmd.Close
End Sub
    TO
    Code:
    Private Sub btnClose_Click()
    DoCmd.Close
End Sub
    Easier to read through code and get a little understanding what the code might do....


    I'm just sayn' .....
    Reply With Quote Reply With Quote
Please reply to this thread with any new information or opinions.
« Previous Thread | Next Thread »

Similar Threads

  1. Forms do not print, completely blank in print preview
    By Error404 in forum Forms
    Replies: 4
    Last Post: 01-20-2016, 02:24 PM
  2. Unbound field prints ok if I use print preview but does not print if I try to print directly
    By XenoZephyr in forum Reports
    Replies: 5
    Last Post: 07-29-2014, 01:05 PM
  3. How to stop Duplicate Parameter Request going from Print Preview to Print in Report
    By shedwyn in forum Reports
    Replies: 6
    Last Post: 03-01-2014, 07:07 AM
  4. Box drawn with me.line on report showing in print preview but not actually printing
    By briand26 in forum Reports
    Replies: 4
    Last Post: 11-18-2013, 03:23 AM
  5. Printing Report on opening print preview without dialog box
    By desk4tbc in forum Programming
    Replies: 1
    Last Post: 10-20-2011, 01:34 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

Forum Rules

Other Forums: Microsoft Office Forums