如何粘贴访问表格的剪贴板屏幕快照到新Outlook电子邮件?
我为Excel找到了很多资源,但是无法让其中任何一个可以通过访问权限100%工作。
我尝试了 this ,但它最终无效,因为我不使用字符串,我正在使用BMP。
this 让我有90%的路线,我能够保存屏幕截图并在剪贴板上看到它,但是我不知道如何进行。我已经尝试了其他资源来构建HTML的新电子邮件,但我无法正常工作。我还尝试构建没有HTML的电子邮件,最终也无法实现。因此,然后我尝试在本地保存文件,然后将其添加到我的电子邮件中,但是代码没有错误但没有保存文件,因此我也碰到了死胡同。
我在这里混合方法,但是我会发布所有内容,所以它已经完成:
在我的访问数据库中,我有一个表格。我单击一个按钮以获取表单的屏幕截图,然后单击另一个按钮,以发送我想粘贴屏幕截图的电子邮件。我能够通过使用查询来创建电子邮件,但这对我不起作用,因为适用于表单的条件格式至关重要,如果只是一个普通的表格,我会失去的。最终,这都是自动的,这些按钮仅用于测试。
表格:
表单代码:
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
这是我正在使用的另一个模块:
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
此运行没有错误。我可以从表单上屏幕截图,并看到它在剪贴板中。它创建了新电子邮件,但不会粘贴,并且在任何地方都不会保存到我的机器上。但是,当我手动执行CTRL+V/粘贴时,它将其粘贴到电子邮件中时,我无法在初始创建时让VBA做到这一点。 SavePicture OPIC没有错误,但实际上没有任何事情。没有弹出的“没有图像”消息。我已经尝试定义一个filepathname,但这也什么也不做。
当前此代码会产生一封电子邮件,例如 this 删除我的格式。如果我删除表格并打糊状的表格,它将带有我的屏幕截图:
我超级卡在这里,我觉得它非常接近工作,但我无法弄清楚。对此的任何帮助将不胜感激,并提前感谢。
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.
如果你对这篇内容有疑问,欢迎到本站社区发帖提问 参与讨论,获取更多帮助,或者扫码二维码加入 Web 技术交流群。

绑定邮箱获取回复消息
由于您还没有绑定你的真实邮箱,如果其他用户或者作者回复了您的评论,将不能在第一时间通知您!
发布评论
评论(1)
最后,我已经开始工作了。这不仅是有效的一件事,而且是几件事,所以我将发布完成这项工作的新代码。请记住,此代码基于带有一个按钮的访问表格,以获取屏幕截图,并以一个按钮发送电子邮件。它也不完美;有时,它需要屏幕的随机部分的屏幕截图,因此我必须单击我的表格并确保它活跃,然后再尝试。有时我也会遇到内存错误,并且屏幕快照出现在路径中,但已断开。但是,当它确实有效时,它可以正常工作,而且我敢肯定所有这些问题都可以解决,因此我将标记该帖子已解决。这是我的工作代码,我会注意到最后的更改。这是表单本身背后的代码:
以及屏幕截图模块的代码:
从蓝色出发,我有一个错误的olepro32.dll。后来有几次扫描告诉我没有错,我最终不得不将其制作Oleaut32.dll,这是朝正确方向迈出的一步。另请注意,您必须做一些额外的事情才能使IMG HTML嵌入工作,我最终重做了整个部分,并用[this] [8]其他帖子中的代码代替了它。
接下来,我必须删除这部分:
我最初链接的那个堆叠量是要保存需要保存的,但是它已经通过其余的过程来完成,并且正在造成错误。我只是完全删除了它。我开始将对象设置为无助,以帮助解决内存问题。
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:
And the code for the screenshot module:
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:
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.