Show controls in acViewPreview but not print (1 Viewer)

oxicottin

Just pecking away....
Local time
Today, 05:03
Joined
Jun 26, 2007
Messages
537
Hello, I have my report open Max in print preview and use a right click menu and I want to change colors of a few controls to save ink when it prints. I tried display only - screen only and it shows the color I want it to go to which is white. Anyways how can I change the color of controls only when it prints?

DoCmd.OpenReport "rpt_SelectedEntry", acViewPreview, , "[VWIID]=" & Me![VWIID]
 

theDBguy

I’m here to help
Local time
Today, 02:03
Joined
Oct 29, 2018
Messages
10,176
May not be the correct answer, but I use two separate versions. One colored, one not.
 

HiTechCoach

Registered User.
Local time
Today, 04:03
Joined
Mar 6, 2006
Messages
4,344
To save colored ink or toner, I go to the printer properties and pick Grayscale.

If possible, I also select "print quality" as "draft" which uses even less ink or toner.
 

oxicottin

Just pecking away....
Local time
Today, 05:03
Joined
Jun 26, 2007
Messages
537
I could do that but the main part of all the color is the header and its red which grayscale would still print it.
 

zeroaccess

Active member
Local time
Today, 04:03
Joined
Jan 30, 2020
Messages
586
Try making a printer-friendly version of your report and on your Print button, DoCmd.OpenReport that report, then invoke the print command, then close and reopen or reactivate the colored one. Kind of an expensive workaround, but there you go.
 
Last edited:

zeroaccess

Active member
Local time
Today, 04:03
Joined
Jan 30, 2020
Messages
586
Or, using one report:

Put printer-friendly copies of all the controls you want underneath your "Screen" controls, or offset by one one click on the grid (so you can select them)
Set a tag property to all of your "Screen" controls
Set a tag property to all of your "Print" controls and set them all to Visible False by default
On click of a button, set all controls with the "Screen" tag value to Visible = False, set "Print" controls to Visible = True, then Print
 

HiTechCoach

Registered User.
Local time
Today, 04:03
Joined
Mar 6, 2006
Messages
4,344
I could do that but the main part of all the color is the header and its red which grayscale would still print it.
OK.

Since you want to use the shortcut (right-click) menu, I would create a custom shortcut menu with an option for "Less Color".

Less color option would call a function to set a TemnpVars:
[COIDE]
TempVars!LessColor = True[/CODE]

When the report prints the On format events will "fire" again.

Code:
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)


If Nz(TempVars!LessColor, 0) = True Then

      Me.[ControlName].BackColor = vbWhite

Else

     Me[ControlName]..BackColor = vbRed

End If
It did test it and it works.
 

oxicottin

Just pecking away....
Local time
Today, 05:03
Joined
Jun 26, 2007
Messages
537
Ok I found a solution and hopefully it helps others....

Code:
Public Function PrintActiveRptFrm() As String
'==================================================================================================
'//Code works with right click for print dialog box for my reports.
'==================================================================================================
Dim rptCur As Access.Report
Set rptCur = Screen.ActiveReport

Dim ctl As Control
For Each ctl In rptCur.Controls
Select Case ctl.ControlType
Case acTextBox
If ctl.Tag = "ColorBlack" Then
ctl.ForeColor = vbBlack
End If
Case acLine
If ctl.Tag = "ColorBlack" Then
ctl.BorderColor = vbBlack
End If
Case acRectangle
If ctl.Tag = "ColorWhite" Then
'rptCur!bxRed.Visible = False
ctl.Visible = False
End If
End Select
    Next ctl

    On Error Resume Next
DoCmd.SelectObject acReport, rptCur
    DoCmd.RunCommand acCmdPrint

    'Close the report
    CloseAllReports

End Function
 

theDBguy

I’m here to help
Local time
Today, 02:03
Joined
Oct 29, 2018
Messages
10,176
Ok I found a solution and hopefully it helps others....

Code:
Public Function PrintActiveRptFrm() As String
'==================================================================================================
'//Code works with right click for print dialog box for my reports.
'==================================================================================================
Dim rptCur As Access.Report
Set rptCur = Screen.ActiveReport

Dim ctl As Control
For Each ctl In rptCur.Controls
Select Case ctl.ControlType
Case acTextBox
If ctl.Tag = "ColorBlack" Then
ctl.ForeColor = vbBlack
End If
Case acLine
If ctl.Tag = "ColorBlack" Then
ctl.BorderColor = vbBlack
End If
Case acRectangle
If ctl.Tag = "ColorWhite" Then
'rptCur!bxRed.Visible = False
ctl.Visible = False
End If
End Select
    Next ctl

    On Error Resume Next
DoCmd.SelectObject acReport, rptCur
    DoCmd.RunCommand acCmdPrint

    'Close the report
    CloseAllReports

End Function
Hi. Thanks. So, how exactly are calling this function?
 

oxicottin

Just pecking away....
Local time
Today, 05:03
Joined
Jun 26, 2007
Messages
537
As a right click menu I'm using the reports "Load" event and in the reports properties "Shortcut Menu Bar = vbaShortCutMenu"

Code:
Private Sub Report_Load()
CreateReportShortcutMenu
End Sub

Private Sub CreateReportShortcutMenu()
'==================================================================================================
'//In the Report_Load Event enter CreateReportShortcutMenu then in the reports Property/Shortcut
' Menu Bar enter the MenuName "vbaShortCutMenu"
'
'//The numbers are Ms Access Control numbers you can download and excel file from MS
'
'//Reference: Microsoft Office 12.0 Object Library
'==================================================================================================

    Dim MenuName As String
Dim CB As CommandBar
    Dim CBB As CommandBarButton

    MenuName = "vbaShortCutMenu"

    On Error Resume Next
Application.CommandBars(MenuName).Delete
    On Error GoTo 0

    'The below code creates the menu I named vbaShortCutMenu
Set CB = Application.CommandBars.Add(MenuName, msoBarPopup, False, False)

'Adds the Print command.
Set CBB = CB.Controls.Add(msoControlButton, 15948, , , True)
CBB.Caption = "Print..."
CBB.Tag = "Print..."
CBB.OnAction = "PrintActiveRptFrm" 'Calls a module

'Adds the Email As .PDF command.
Set CBB = CB.Controls.Add(msoControlButton, 2188, , , True)
CBB.Caption = "Send E-mail..."
CBB.Tag = "Send E-mail..."
CBB.OnAction = "=EmailAsPDF()" 'Calls a module

'Adds the Save As .PDF command.
Set CBB = CB.Controls.Add(msoControlButton, 12499, , , True)
CBB.Caption = "Save As PDF..."

'Adds the Close command.
Set CBB = CB.Controls.Add(msoControlButton, 923, , , True)
'Starts a new group.
CBB.BeginGroup = True
'Change the caption displayed for the control.
CBB.Caption = "Close Report"
CBB.OnAction = "CloseAllReports" 'Calls a module
Set CB = Nothing
    Set CBB = Nothing

End Sub
Then here is the Module "mod_ShortCutMenuCommands" I'm calling/using for the functions:

Code:
Option Compare Database
Option Explicit

Public Function PrintActiveRptFrm() As String
'==================================================================================================
'//Code works with right click for print dialog box for my reports.
'==================================================================================================
Dim rptCur As Access.Report
Set rptCur = Screen.ActiveReport

'To save on color, loop thour controls in the header to print in black and hide the red
Dim ctl As Control
For Each ctl In rptCur.Controls
Select Case ctl.ControlType
Case acTextBox
If ctl.Tag = "ColorBlack" Then
ctl.ForeColor = vbBlack
End If
Case acLine
If ctl.Tag = "ColorBlack" Then
ctl.BorderColor = vbBlack
End If
Case acRectangle
If ctl.Tag = "ColorWhite" Then
ctl.Visible = False
End If
End Select
    Next ctl

    On Error Resume Next
DoCmd.SelectObject acReport, rptCur
    DoCmd.RunCommand acCmdPrint

    'Close the report
    CloseAllReports

End Function

Public Function EmailAsPDF()
'==================================================================================================
'//Code works with right click for my reports
'
'//Reference: Microsoft Outlook 12.0 Object Library
'==================================================================================================
On Error GoTo Error_Handler
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Dim strSubject As String
Dim strMessageText As String
Dim rptCur As Access.Report
Dim AttachmentName As String
    Set rptCur = Screen.ActiveReport

    strSubject = "Subjects Name"
strMessageText = "Message Text"

Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)
AttachmentName = SaveOpenReportAsPDF(rptCur.Name)
'Debug.Print AttachmentName
With objEmail
'.To = strgTo
.Subject = strSubject
.Body = strMessageText
.Attachments.Add AttachmentName
.Display
End With
DeleteSavedReport AttachmentName 'Deletes the saved .pdf
CloseAllReports 'Close Report
Exit_Here:
Set objOutlook = Nothing
Exit Function
Error_Handler:
MsgBox Err & ": " & Err.Description
CloseAllReports
Resume Exit_Here
End Function

Public Function SaveOpenReportAsPDF(strReportName As String) As String
'==================================================================================================
'Create report and save as an attachment to the current record
'==================================================================================================
Dim myCurrentDir As String
Dim myReportOutput As String
    Dim myMessage As String

    On Error GoTo ErrorHandler
myCurrentDir = CurrentProject.Path & "\"
myReportOutput = myCurrentDir & strReportName & ".pdf"
If Dir(myReportOutput) <> "" Then ' the file already exists--delete it first.
VBA.SetAttr myReportOutput, vbNormal ' remove any file attributes (e.g. read-only) that would block the kill command.
VBA.Kill myReportOutput ' delete the file.
End If
DoCmd.OutputTo acOutputReport, strReportName, acFormatPDF, myReportOutput, , , , acExportQualityPrint
SaveOpenReportAsPDF = myReportOutput
Exit Function
ErrorHandler:
MsgBox Error$
End Function

Public Function DeleteSavedReport(FileName As String)
'==================================================================================================
'//Delete the saved .pdf, Filename is complete path and file name
'==================================================================================================
On Error GoTo ErrorHandler
If Dir(FileName) <> "" Then ' the file already exists--delete it
VBA.SetAttr FileName, vbNormal ' remove any file attributes (e.g. read-only) that would block the kill command.
VBA.Kill FileName ' delete the file.
End If
ErrorHandler:
MsgBox Error$
End Function

Public Sub CloseAllReports()
'==================================================================================================
'//Code used to close the current report
'==================================================================================================
Dim rpt As Access.Report
For Each rpt In Application.Reports
DoCmd.Close acReport, rpt.Name
Next rpt
End Sub
Here is the Module "mod_GetImagePath" to get the current path which is using in the mod above and I use for other stuff.... Notice there are two of the same functions. Right now im using the top one and when I split my DB ill use the bottom one....

Code:
Public Function GetCurrentPath() As String

         'Gets path of current DB is DB isnt split
GetCurrentPath = Application.CurrentProject.Path '& "\"

End Function


'Public Function GetCurrentPath() As String
 'Gets path of current BE table. Move image folder in with BE

    'Dim strFullPath As String
'strFullPath = Mid(DBEngine.Workspaces(0).Databases(0).TableDefs("tbl_VWI").Connect, 11)
'GetCurrentPath = Left(strFullPath, InStrRev(strFullPath, "\"))
'End Function
 

theDBguy

I’m here to help
Local time
Today, 02:03
Joined
Oct 29, 2018
Messages
10,176
As a right click menu I'm using the reports "Load" event and in the reports properties "Shortcut Menu Bar = vbaShortCutMenu"

Code:
Private Sub Report_Load()
CreateReportShortcutMenu
End Sub

Private Sub CreateReportShortcutMenu()
'==================================================================================================
'//In the Report_Load Event enter CreateReportShortcutMenu then in the reports Property/Shortcut
' Menu Bar enter the MenuName "vbaShortCutMenu"
'
'//The numbers are Ms Access Control numbers you can download and excel file from MS
'
'//Reference: Microsoft Office 12.0 Object Library
'==================================================================================================

    Dim MenuName As String
Dim CB As CommandBar
    Dim CBB As CommandBarButton

    MenuName = "vbaShortCutMenu"

    On Error Resume Next
Application.CommandBars(MenuName).Delete
    On Error GoTo 0

    'The below code creates the menu I named vbaShortCutMenu
Set CB = Application.CommandBars.Add(MenuName, msoBarPopup, False, False)

'Adds the Print command.
Set CBB = CB.Controls.Add(msoControlButton, 15948, , , True)
CBB.Caption = "Print..."
CBB.Tag = "Print..."
CBB.OnAction = "PrintActiveRptFrm" 'Calls a module

'Adds the Email As .PDF command.
Set CBB = CB.Controls.Add(msoControlButton, 2188, , , True)
CBB.Caption = "Send E-mail..."
CBB.Tag = "Send E-mail..."
CBB.OnAction = "=EmailAsPDF()" 'Calls a module

'Adds the Save As .PDF command.
Set CBB = CB.Controls.Add(msoControlButton, 12499, , , True)
CBB.Caption = "Save As PDF..."

'Adds the Close command.
Set CBB = CB.Controls.Add(msoControlButton, 923, , , True)
'Starts a new group.
CBB.BeginGroup = True
'Change the caption displayed for the control.
CBB.Caption = "Close Report"
CBB.OnAction = "CloseAllReports" 'Calls a module
Set CB = Nothing
    Set CBB = Nothing

End Sub
Then here is the Module "mod_ShortCutMenuCommands" I'm calling/using for the functions:

Code:
Option Compare Database
Option Explicit

Public Function PrintActiveRptFrm() As String
'==================================================================================================
'//Code works with right click for print dialog box for my reports.
'==================================================================================================
Dim rptCur As Access.Report
Set rptCur = Screen.ActiveReport

'To save on color, loop thour controls in the header to print in black and hide the red
Dim ctl As Control
For Each ctl In rptCur.Controls
Select Case ctl.ControlType
Case acTextBox
If ctl.Tag = "ColorBlack" Then
ctl.ForeColor = vbBlack
End If
Case acLine
If ctl.Tag = "ColorBlack" Then
ctl.BorderColor = vbBlack
End If
Case acRectangle
If ctl.Tag = "ColorWhite" Then
ctl.Visible = False
End If
End Select
    Next ctl

    On Error Resume Next
DoCmd.SelectObject acReport, rptCur
    DoCmd.RunCommand acCmdPrint

    'Close the report
    CloseAllReports

End Function

Public Function EmailAsPDF()
'==================================================================================================
'//Code works with right click for my reports
'
'//Reference: Microsoft Outlook 12.0 Object Library
'==================================================================================================
On Error GoTo Error_Handler
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Dim strSubject As String
Dim strMessageText As String
Dim rptCur As Access.Report
Dim AttachmentName As String
    Set rptCur = Screen.ActiveReport

    strSubject = "Subjects Name"
strMessageText = "Message Text"

Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)
AttachmentName = SaveOpenReportAsPDF(rptCur.Name)
'Debug.Print AttachmentName
With objEmail
'.To = strgTo
.Subject = strSubject
.Body = strMessageText
.Attachments.Add AttachmentName
.Display
End With
DeleteSavedReport AttachmentName 'Deletes the saved .pdf
CloseAllReports 'Close Report
Exit_Here:
Set objOutlook = Nothing
Exit Function
Error_Handler:
MsgBox Err & ": " & Err.Description
CloseAllReports
Resume Exit_Here
End Function

Public Function SaveOpenReportAsPDF(strReportName As String) As String
'==================================================================================================
'Create report and save as an attachment to the current record
'==================================================================================================
Dim myCurrentDir As String
Dim myReportOutput As String
    Dim myMessage As String

    On Error GoTo ErrorHandler
myCurrentDir = CurrentProject.Path & "\"
myReportOutput = myCurrentDir & strReportName & ".pdf"
If Dir(myReportOutput) <> "" Then ' the file already exists--delete it first.
VBA.SetAttr myReportOutput, vbNormal ' remove any file attributes (e.g. read-only) that would block the kill command.
VBA.Kill myReportOutput ' delete the file.
End If
DoCmd.OutputTo acOutputReport, strReportName, acFormatPDF, myReportOutput, , , , acExportQualityPrint
SaveOpenReportAsPDF = myReportOutput
Exit Function
ErrorHandler:
MsgBox Error$
End Function

Public Function DeleteSavedReport(FileName As String)
'==================================================================================================
'//Delete the saved .pdf, Filename is complete path and file name
'==================================================================================================
On Error GoTo ErrorHandler
If Dir(FileName) <> "" Then ' the file already exists--delete it
VBA.SetAttr FileName, vbNormal ' remove any file attributes (e.g. read-only) that would block the kill command.
VBA.Kill FileName ' delete the file.
End If
ErrorHandler:
MsgBox Error$
End Function

Public Sub CloseAllReports()
'==================================================================================================
'//Code used to close the current report
'==================================================================================================
Dim rpt As Access.Report
For Each rpt In Application.Reports
DoCmd.Close acReport, rpt.Name
Next rpt
End Sub
Here is the Module "mod_GetImagePath" to get the current path which is using in the mod above and I use for other stuff.... Notice there are two of the same functions. Right now im using the top one and when I split my DB ill use the bottom one....

Code:
Public Function GetCurrentPath() As String

         'Gets path of current DB is DB isnt split
GetCurrentPath = Application.CurrentProject.Path '& "\"

End Function


'Public Function GetCurrentPath() As String
'Gets path of current BE table. Move image folder in with BE

    'Dim strFullPath As String
'strFullPath = Mid(DBEngine.Workspaces(0).Databases(0).TableDefs("tbl_VWI").Connect, 11)
'GetCurrentPath = Left(strFullPath, InStrRev(strFullPath, "\"))
'End Function
Thanks!
 

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

Top Bottom