I've found a lot of resources for this for Excel, but have not been able to get any of them to work 100% with Access.
I tried this, but it ultimately didn't work because I'm not working with a string, I'm working with a bmp.
This post got me 90% of the way there, I am able to save the screenshot and see it in the clipboard, but I can't figure out how to proceed. I've tried other resources that build a new email from HTML, but I couldn't get that to work. I also tried building an email without HTML, and ultimately also could not get that to work. So then I tried to save the file locally and then add it to my email, but the code runs with no errors but doesn't save the file, so I hit a dead end there as well.
I'm mixing methods here, but I will post everything I have so it's complete:
In my Access database, I have a form. I click one button to take the screenshot of the form, and another button to send the email that I want to paste the screenshot into. I was able to create the email by using the query, but this doesn't work for me because the conditional formatting applied to the form is critical, and I lose that if it's just a plain table. Eventually this will all be automatic, the buttons are just for testing.
The form:
Form code:
Option Compare Database
Option Explicit
Private Sub Command15_Click()
Screenshot.PrintScreen
End Sub
Public Sub Command4_Click()
Dim olapp As Object
Dim olItem As Variant
Dim strQry As String
Dim aHead(1 To 3) As String
Dim aRow(1 To 3) As String
Dim aBody() As String
Dim lCnt As Long
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim db As Variant
Dim rec As Variant
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
Dim preamble As String
'Create the header row
aHead(1) = "AGC"
aHead(2) = "Battery Install Date"
aHead(3) = "Last EQ Charge"
preamble = "This email has been sent automatically because an AGC is due for an EQ charge. Please refer to the below table."
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From Query"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("AGC")
aRow(2) = rec("Battery Install Date")
aRow(3) = rec("Last EQ Charge")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
DataObj.GetFromClipboard
'strPaste = DataObj.GetText(1) 'Insert contents from clipboard to this variable so it can be added to email body
'create the email
Set olapp = CreateObject("Outlook.application")
Set olItem = olapp.CreateItem(0)
'olItem.Display
olItem.To = "[email protected]"
olItem.Subject = "AGC Battery Notification"
olItem.HTMLBody = Join(aBody, vbNewLine) '"<p><font face=""Times New Roman"" size=""3"" color=""red""><b>" & preamble & "</b></font></p><p></p>"
olItem.Display
End Sub
Here is the other module I'm using:
Option Compare Database
Option Explicit
Public Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_SNAPSHOT = &H2C
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
'\\ Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'\\ Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
type As Long
hPic As Long
hPal As Long
End Type
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Sub PrintScreen()
keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub
Public Sub MyPrintScreen(FilePathName As String)
Call PrintScreen
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
'\\ Create the interface GUID for the picture
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
'\\ Fill uPicInfo with necessary parts.
With uPicinfo
.Size = Len(uPicinfo) '\\ Length of structure.
.type = PICTYPE_BITMAP '\\ Type of Picture
.hPic = hPtr '\\ Handle to image.
.hPal = 0 '\\ Handle to palette (if bitmap).
End With
'\\ Create the Range Picture Object
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
'\\ Save Picture Object
stdole.SavePicture IPic, FilePathName
Dim oPic
On Error Resume Next
Set oPic = Clipboard.GetData
On Error GoTo 0
If oPic Is Nothing Then
MsgBox "No image"
Else
SavePicture oPic, "C:\pic.jpg"
End If
End Sub
This runs with no errors. I can take a screenshot from the form and see that it is in the clipboard. It creates the new email, but doesn't paste, and doesn't save to my machine anywhere. But when I manually do CTRL V/Paste, it pasted into the email just fine but I can't get VBA to do that on initial creation. SavePicture oPic runs without errors but doesn't actually do anything. There is no "no image" message that pops up. I've tried defining a FilePathName, but that also just does nothing.
Picture of screenshot in the clipboard
Currently this code produces an email like this which removes my formatting. If I delete the table it pulls in and hit paste, it brings in my screenshot:
Here are all of the references I am using
I'm super stuck here, I feel like it's so close to working but I can't figure it out. Any help with this is appreciated and thanks in advance.
CodePudding user response：
At long last, I have gotten it to work. It wasn't just a single thing that worked, it was several minor things so I will post the new code that does the job. Keep in mind that this code is based on an Access form with one button to take the screenshot, and one button to send the email. It is also not perfect; it sometimes takes a screenshot of a random part of the screen, so I have to click on my form and make sure it's active before trying again. I also sometimes get memory errors and the screenshot shows up in the path, but it's broken. However, when it does work it works fine, and I'm sure all of these issues can be solved so I am going to mark this post solved. Here is my working code and I will note the changes at the end. This is the code behind the form itself:
Option Compare Database
Option Explicit
Private Sub Command15_Click()
Screenshot.MyPrintScreen ("C:\Temp\test.jpg")
End Sub
Public Sub Command4_Click()
Dim oApp As Outlook.Application
Dim oEmail As MailItem
Dim colAttach As Outlook.Attachments
Dim oAttach As Outlook.Attachment
'create new Outlook MailItem
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)
'add graphic as attachment to Outlook message
'change path to graphic as needed
Set colAttach = oEmail.Attachments
Set oAttach = colAttach.Add("C:\temp\test.jpg")
oEmail.Close olSave
'change the src property to 'cid:your picture filename'
'it will be changed to the correct cid when its sent.
oEmail.HTMLBody = "<BODY><IMG src=""cid:test.jpg"" </BODY>"
oEmail.Save
oEmail.To = "[email protected]"
oEmail.Subject = "test"
oEmail.Display
'oEmail.Send
Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing
End Sub
And the code for the screenshot module:
Option Compare Database
Option Explicit
Public Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_SNAPSHOT = &H2C
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'\\ Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'\\ Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
type As Long
hPic As Long
hPal As Long
End Type
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Sub PrintScreen()
keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub
Public Sub MyPrintScreen(FilePathName As String)
Call PrintScreen
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
'\\ Create the interface GUID for the picture
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
'\\ Fill uPicInfo with necessary parts.
With uPicinfo
.Size = Len(uPicinfo) '\\ Length of structure.
.type = PICTYPE_BITMAP '\\ Type of Picture
.hPic = hPtr '\\ Handle to image.
.hPal = 0 '\\ Handle to palette (if bitmap).
End With
'\\ Create the Range Picture Object
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
'\\ Save Picture Object
stdole.SavePicture IPic, FilePathName
Set DataObj = Nothing
End Sub
Out of the blue I had an error for a missing olepro32.dll. Several scans later telling me there was nothing wrong, I ended up having to make it oleaut32.dll and that was a step in the right direction. Also note that you have to do some extra stuff in order to get the img HTML embedding to work, I ended up redoing that entire section and replacing it with code found from [this][8] other post.
Next I had to delete this part:
Dim oPic
On Error Resume Next
Set oPic = Clipboard.GetData
On Error GoTo 0
If oPic Is Nothing Then
MsgBox "No image"
Else
SavePicture oPic, "C:\pic.jpg"
End If
That stackoverflow I linked originally says it was needed to save, but it was already being done by the rest of the procedure and it was causing errors. I just deleted it entirely. I began setting objects to none to help with the memory problems.