VB6 - Spreadsheet generates blank pages with no records.
Good morning everyone.
I'm sure everybody is now familiar with my non-stop posting with my spreadsheet issues. I am populating a spreadsheet/report using vb. I am using a query/table as my input files. The problem is even if program executes and processes only one record, when I go to the spreadsheet "PrintPreview", I see stuff like "Page 1 of 22". Why is it generating all these pages while it only processed one record? Also, some times it prints blank pages.
Can anyone tell me how I can fix this? Module#1:
Set rsin = M.DB.OpenRecordset("qBiWeeklyPeriodCombined", dbOpenDynaset)
Set rsSrtSelStr = M.DB.OpenRecordset("TblSelectionString", dbOpenDynaset)
If rsin.RecordCount <= 0 Then
MsgBox "There are no records for your selection String/Criteria", vbInformation, "PTS System"
Exit Function
End If
Set xlApp = CreateObject("Excel.Application")
Set xlWbk = xlApp.Workbooks.Open("C:\BiWeeklyPeriod.xls")
Set xlWksht = xlWbk.Worksheets(1)
xlWksht.UsedRange.ClearContents
xlWksht.Cells(2, 1).Value = rsSrtSelStr![SelectionString]
xlWksht.Cells(3, 1).Value = rsSrtSelStr![SortString]
xlWksht.Range("A2:K2").MergeCells = True
xlWksht.Range("A3:K3").MergeCells = True
ii = 4
ii = ii + 1
xlWksht.Cells(ii, 1).Value = Chr(10) & "Req" & Chr(10) & "No"
xlWksht.Cells(ii, 2).Value = Chr(10) & Chr(10) & "Description"
xlWksht.Cells(ii, 3).Value = Chr(10) & "PL" & Chr(10) & "Pgr"
xlWksht.Cells(ii, 4).Value = Chr(10) & "Client Name" & Chr(10) & "& Status"
xlWksht.Cells(ii, 5).Value = Chr(10) & "Current" & Chr(10) & "Hours"
xlWksht.Cells(ii, 6).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "Tot Hrs"
xlWksht.Cells(ii, 7).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "Start Date"
xlWksht.Cells(ii, 8).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "End Date"
xlWksht.Range("A5:H5").Select
With Selection.Font
.FontStyle = "Bold"
.Size = 8
.Underline = xlUnderlineStyleDouble
End With
xlWksht.Range("A:A").Font.Bold = True
xlWksht.Range("A:A").HorizontalAlignment = xlLeft
ii = 5
w = 0
For Each R In xlWksht.Range("A8:h8"): w = w + R.ColumnWidth: Next
rht = xlWksht.Range("A6").RowHeight
If rht > 409 Then
rht = 409
Else
rht = xlWksht.Range("A6").RowHeight
End If
Do Until rsin.EOF = True
ii = ii + 2
xlWksht.Cells(ii, 1).Value = rsin![Req No]
xlWksht.Cells(ii, 2).Value = rsin![Description]
xlWksht.Cells(ii, 3).Value = rsin![P L] & Chr(10) & rsin![Pgmr2] & Chr(10) & rsin![Pgmr3]
xlWksht.Cells(ii, 4).Value = rsin![ClientName] & Chr(10) & rsin![Status]
xlWksht.Cells(ii, 5).Value = "-" & Chr(10) & rsin![Per Hrs]
xlWksht.Cells(ii, 6).Value = rsin![Hours] & Chr(10) & rsin![Tot Hrs]
xlWksht.Cells(ii, 7).Value = rsin![Start Date] & Chr(10) & rsin![Start Date]
xlWksht.Cells(ii, 8).Value = rsin![End Date] & Chr(10) & rsin![End Date]
'xlWksht.Cells(ii + 1, 1).Value = "Comments:" & Chr(10) & "'" & xlApp.Clean(Trim(rsin![Comments]))
If rsin![Comments] = "" Or IsNull(rsin![Comments]) Then
mystr = "Comments:" & Chr(10) & "NO COMMENTS FOR THIS RECORD!"
Else
mystr = "Comments:" & "'" & xlApp.Clean(Trim(rsin![Comments]))
End If
'New Logic 9/19/2007
If rsin.RecordCount > 0 And mystr > "" Then
Do
newlinecnt = 0
Pos = InStr(Pos + 1, mystr, ":")
If Not Pos = 0 Then
If Mid(mystr, Pos - 5, 1) = "/" Then
mystr = Left(mystr, Pos - 11) & Chr(10) & Mid(mystr, Pos - 10, 10) & Chr(10) & Mid(mystr, Pos + 1)
newlinecnt = newlinecnt + 2
Pos = Pos + 2
End If
End If
Loop While Not Pos = 0
xlWksht.Cells(ii + 1, 1).Value = mystr
'xlWksht.Cells(ii + 1, 1).Value = "Comments:" 'Left(mystr, 10)
'xlWksht.Cells(ii + 1, 2).Value = Mid(mystr, 11)
With xlWksht.Range(xlWksht.Cells(ii + 1, 1), xlWksht.Cells(ii + 1, 8))
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.IndentLevel = 0
.MergeCells = True
.RowHeight = .Font.Size * (Len(xlWksht.Range("A" & ii + 1).text) - Len("Comments:")) / w + rht + (rht - .Font.Size) ' + newlinecnt * .Font.Size
End With
xlWksht.Columns("A:A").ColumnWidth = 9.15
xlWksht.Columns("B:B").ColumnWidth = 23
End If
rsin.MoveNext
Loop
xlWksht.PageSetup.LeftFooter = " Legend:" & Chr(10) & "See Tot Hrs. Column: Top Number = Estimated Hrs. and Bottom Number = Actual Hrs." & Chr(10) & "See Dates Columns: Top dates = Estimated Start/End dates and Bottom dates = Actual Start/End dates"
'xlWksht.Range("A6").CopyFromRecordset rsin
xlApp.ActiveWorkbook.Save
MsgBox ("If you need to print this spreadsheet and because of Excel report limitations, You may need to go into the spreadsheet and Manually expand the rows to enable you see hidden data in some rows"), vbInformation, "ATTENTION!"
xlApp.Visible = True
xlApp.UserControl = True
rsin.Close
rsSrtSelStr.Close
Set xlWbk = Nothing
Set xlWksht = Nothing
Set xlApp = Nothing
M.DB.Close
Exit FunctionModule#2
Private Function BiWeeklyPeriodProgExportCriteria()
'On Error GoTo Errorhandler
Dim recordcnt As Long
Dim SrchCriteria As String
Dim P As Integer
Dim R As Range
Dim w As Long
Dim rht As Long
Dim TStr As String
Dim Pos As Integer
Dim mystr As String
Dim newlinecnt As Integer
'GX code2 begin here Modified 6/7/2007 1:00PM:
'--------------------------------------------
Set M.qBW = M.DB.OpenRecordset("qBiWeeklyPeriodProgrammer", dbOpenDynaset)
Set rsinPers = M.DB.OpenRecordset("TblPersonnel", dbOpenDynaset)
Set rsSrtSelStr = M.DB.OpenRecordset("TblSelectionString", dbOpenDynaset)
Set xlApp = CreateObject("Excel.Application")
Set xlWbk = xlApp.Workbooks.Open("C:\BiWeeklyPeriodProg.xls")
Set xlWksht = xlWbk.Worksheets(1)
M.qBW.Sort = "Req No"
xlWksht.Activate
xlWksht.UsedRange.ClearContents
xlWksht.Cells(2, 1).Value = rsSrtSelStr![SelectionString]
xlWksht.Cells(3, 1).Value = rsSrtSelStr![SortString]
xlWksht.Range("A2:F2").MergeCells = True
xlWksht.Range("A3:F3").MergeCells = True
'Write Spreadsheet headers:
'--------------------------
ii = 4
ii = ii + 1
xlWksht.Cells(ii, 1).Value = Chr(10) & "Req" & Chr(10) & "No"
xlWksht.Cells(ii, 2).Value = Chr(10) & Chr(10) & "Description"
xlWksht.Cells(ii, 3).Value = ""
xlWksht.Cells(ii, 4).Value = Chr(10) & "Client Name" & Chr(10) & "& Status"
xlWksht.Cells(ii, 5).Value = Chr(10) & "PL" & Chr(10) & "Hrs"
xlWksht.Cells(ii, 6).Value = Chr(10) & "Pr2" & Chr(10) & "Hrs"
xlWksht.Cells(ii, 7).Value = Chr(10) & "Pr3" & Chr(10) & "Hrs"
xlWksht.Cells(ii, 8).Value = Chr(10) & "Pr4" & Chr(10) & "Hrs"
xlWksht.Cells(ii, 9).Value = Chr(10) & "Pr5" & Chr(10) & "Hrs"
xlWksht.Cells(ii, 10).Value = Chr(10) & "Pr6" & Chr(10) & "Hrs"
xlWksht.Cells(ii, 11).Value = Chr(10) & "Current" & Chr(10) & "Hours"
xlWksht.Cells(ii, 12).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "Tot Hrs"
xlWksht.Cells(ii, 13).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "Start Date"
xlWksht.Cells(ii, 14).Value = "Estimated" & Chr(10) & "Actual" & Chr(10) & "End Date"
'Format spreadsheet headers:
'---------------------------
xlWksht.Range("A5:N5").Select
With Selection.Font
.FontStyle = "Bold"
.Size = 8
.Underline = xlUnderlineStyleDouble
End With
xlWksht.Range("A:A").Font.Bold = True
xlWksht.Range("A:A").HorizontalAlignment = xlLeft
xlWksht.Rows("5:5").RowHeight = 42.75
xlWksht.Range("A:A").ColumnWidth = 5
xlWksht.Columns("B").ColumnWidth = 27
xlWksht.Columns("C:C").ColumnWidth = 3.86
xlWksht.Columns("D:D").ColumnWidth = 10.71
xlWksht.Columns("D:D").HorizontalAlignment = xlLeft
xlWksht.Columns("E:J").ColumnWidth = 3
xlWksht.Columns("K:K").ColumnWidth = 6.14
xlWksht.Columns("L:N").ColumnWidth = 10
'Populate Spreadsheet:
'---------------------
M.qBW.MoveFirst
rsinPers.MoveFirst
ii = 5
w = 0
For Each R In xlWksht.Range("A5:N5"): w = w + R.ColumnWidth: Next
rht = xlWksht.Range("A5").RowHeight
If rht > 409 Then
rht = 409
Else
rht = xlWksht.Range("A6").RowHeight
End If
Do Until M.qBW.EOF = True
ii = ii + 2
xlWksht.Cells(ii, 1).Value = M.qBW![Req No]
xlWksht.Cells(ii, 2).Value = M.qBW![Description]
xlWksht.Cells(ii, 3).Value = ""
xlWksht.Cells(ii, 4).Value = M.qBW![ClientName] & Chr(10) & M.qBW![Status]
xlWksht.Cells(ii, 5).Value = M.qBW![P L] & Chr(10) & M.qBW![TotalProg1Hrs]
SrchCriteria = "[Name]= " & "'" & M.qBW![Personnel2] & "'"
rsinPers.FindFirst SrchCriteria
If rsinPers.NoMatch = False Then
xlWksht.Cells(ii, 6).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg2Hrs]
End If
SrchCriteria = "[Name]= '" & M.qBW![Personnel3] & "'"
rsinPers.FindFirst SrchCriteria
If rsinPers.NoMatch = False Then
xlWksht.Cells(ii, 7).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg3Hrs]
End If
SrchCriteria = "[Name]= '" & M.qBW![Personnel4] & "'"
rsinPers.FindFirst SrchCriteria
If rsinPers.NoMatch = False Then
xlWksht.Cells(ii, 8).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg4Hrs]
End If
SrchCriteria = "[Name]= '" & M.qBW![Personnel5] & "'"
rsinPers.FindFirst SrchCriteria
If rsinPers.NoMatch = False Then
xlWksht.Cells(ii, 9).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg5Hrs]
End If
SrchCriteria = "[Name]= '" & M.qBW![Personnel6] & "'"
rsinPers.FindFirst SrchCriteria
If rsinPers.NoMatch = False Then
xlWksht.Cells(ii, 10).Value = rsinPers![Initials] & Chr(10) & M.qBW![TotalProg6Hrs]
End If
xlWksht.Cells(ii, 11).Value = "-" & Chr(10) & M.qBW.Fields("Per Hrs")
xlWksht.Cells(ii, 12).Value = M.qBW.Fields("EstimatedTotalHours") & Chr(10) & M.qBW.Fields("Tot Hrs")
xlWksht.Cells(ii, 13).Value = M.qBW![Start Date] & Chr(10) & M.qBW![Start Date]
xlWksht.Cells(ii, 14).Value = M.qBW![End Date] & Chr(10) & M.qBW![End Date]
If M.qBW![Comments] = "" Or IsNull(M.qBW![Comments]) Then
mystr = "Comments:" & Chr(10) & "NO COMMENTS FOR THIS RECORD!"
Else
mystr = "Comments:" & "'" & xlApp.Clean(Trim(M.qBW![Comments]))
End If
If mystr <> "" Then
Do
Pos = InStr(Pos + 1, mystr, ":")
If Not Pos = 0 Then
If Mid(mystr, Pos - 5, 1) = "/" Then
mystr = Left(mystr, Pos - 11) & Chr(10) & Mid(mystr, Pos - 10, 10) & Chr(10) & Mid(mystr, Pos + 1)
Pos = Pos + 2
End If
End If
Loop While Not Pos = 0
'xlWksht.Cells(ii + 1, 1).Value = mystr
xlWksht.Cells(ii + 1, 1).Value = "Comments:" 'Left(mystr, 10)
xlWksht.Cells(ii + 1, 2).Value = Mid(mystr, 11)
'Note: changed(ii + 1, 1) to (ii + 1, 2)
With xlWksht.Range(xlWksht.Cells(ii + 1, 2), xlWksht.Cells(ii + 1, 14))
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.MergeCells = True
.RowHeight = .Font.Size * (Len(xlWksht.Range("A" & ii + 2).text) - Len("Comments:")) / w + rht + (rht - .Font.Size) ' + newlinecnt * .Font.Size
End With 'Note: changed above from ("A" & ii + 1) to ("A" & ii + 2)
xlWksht.Columns("A:A").ColumnWidth = 9.15
TStr = "A" & CStr(ii + 1) & ":N" & CStr(ii + 1) ' Note: changed ":M" to ":N"
xlWksht.Range(TStr).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
M.qBW.MoveNext
Loop
'Adding an invisible comment to spreadsheet:
'-------------------------------------------
'xlWksht.Cells(ii + 3, 1).AddComment "Legend:" & "The last four columns to the right of this report, The top numbers and dates = Estimated hours, Estimated start/End dates, Bottom numbers and dates = Actual hours, Actual start/End dates"
xlWksht.PageSetup.LeftFooter = " Legend:" & Chr(10) & "See Total Hrs. Column: Top Number = Estimated Hrs. and Bottom Number = Actual Hrs." & Chr(10) & "See Dates Columns: Top dates = Estimated Start/End dates and Bottom dates = Actual Start/End dates"
'xlWksht.Range("A6").CopyFromRecordset M.qBW 'M.qBW
xlApp.ActiveWorkbook.Save
MsgBox ("If you need to print this spreadsheet and because of Excel report limitations, You may need to go into the spreadsheet and Manually expand the rows to enable you see hidden data in some rows"), vbInformation, "ATTENTION!"
xlApp.Visible = True
xlApp.UserControl = True
rsinPers.Close
M.qBW.Close
rsSrtSelStr.Close
Set xlWbk = Nothing
Set xlWksht = Nothing
Set xlApp = Nothing
M.DB.Close
Exit FunctionThanks.
tgif