Morning Guys. I have been struggling to get a print screen to run reliably. I saw some posts about using a 3rd party print screen software. If this is the way to go can someone suggest the best one to go with. I am green to VB but have assembled the attached code. Any suggestions to make it cleaner are welcome. Sometimes the print screen works. Other times it will printscreen a different page. And lastly sometimes it locks up on the windows printscreen line.
Code:
Private Sub PrintDisplay_Change()
On Error GoTo errorhandler
If Not IsError(PrintDisplay.Value) Then
If PrintDisplay.Value = 1 Then
ExecuteCommand ("display Something")
Button1.Visible = False
Button2.Visible = False
BL_Zoom_Out.Visible = False
BL_Zoom_In.Visible = False
BL_Reset_PB.Visible = False
BL_Pan_Newer.Visible = False
BL_Pan_Older.Visible = False
Application.LogDiagnosticsMessage ("Prepared for Something Downtime Trend PrintScreen")
[COLOR="Magenta"]Windows.Application.SendKeys "(%{1068})" ' Windows Printscreen
DoEvents[/COLOR]
Application.LogDiagnosticsMessage ("Something PrintScreen Complete")
Button1.Visible = True
Button2.Visible = True
BL_Zoom_Out.Visible = True
BL_Zoom_In.Visible = True
BL_Reset_PB.Visible = True
BL_Pan_Newer.Visible = True
BL_Pan_Older.Visible = True
Dim objexcelapp As Object
Dim fname As String
Dim fsave As String
Dim dblank As String
'Create PDF
fname = "BRG " & Format(Now, "mmm-dd-yyyy") & " Time " & Format(Now, "hh-mm-ss")
fsave = "c:\BackupReports\" & fname
dblank = "c:\backupreports\VTR.xlsx"
Set objexcel = CreateObject("excel.application")
objexcel.Visible = True
objexcel.Workbooks.Open (dblank)
objexcel.ActiveSheet.Paste
objexcel.ActiveSheet.PageSetup.PrintArea = "$a$1:$ae$52"
With objexcel.ActiveSheet.PageSetup
.LeftMargin = objexcel.Application.InchesToPoints(0.25)
.RightMargin = objexcel.Application.InchesToPoints(0.25)
.TopMargin = objexcel.Application.InchesToPoints(0.5)
.BottomMargin = objexcel.Application.InchesToPoints(0.25)
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Zoom = False
FitToPagesWide = False
FitToPagesTall = False
End With
objexcel.ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=fname, _
quality:=x1qualitystandard, _
openafterpublish:=False
objexcel.ActiveWorkbook.SaveAs (fsave)
objexcel.Workbooks(fname).Close (False)
objexcel.Quit
Set objexcelapp = Nothing
'Grab email list
Dim ToList As String
Dim EMB As String
EMB = "C:\BackupReports\EmailList_Worksheet.xlsx"
Set objexcel = CreateObject("excel.application")
objexcel.Visible = True
objexcel.Workbooks.Open (EMB)
ToList = objexcel.Range("t55")
objexcel.Workbooks("EmailList_Worksheet").Close (False)
objexcel.Quit
Set objexcelapp = Nothing
'Send Email
Dim objapp As Object
Dim objmail As Outlook.MailItem
Set objapp = CreateObject("Outlook.Application")
Set objmail = objapp.CreateItem(0)
With objmail
.To = ""
.CC = ""
.BCC = ToList
.Subject = "Something"
.ReadReceiptRequested = False
.BodyFormat = olFormatHTML
.HTMLBody = "Automated Email"
.Attachments.Add fname & ".pdf"
.Save
.Send
End With
Set objapp = Nothing
Set objmail = Nothing
ExecuteCommand "display something"
If something.Value = 1 Then
ExecuteCommand ("display alarms_banner")
End If
End If
End If
Exit Sub
errorhandler:
LogDiagnosticsMessage Err.Number & " " & Err.Description, ftDiagSeverityError
End Sub