我为Excel找到了很多资源，但无法让其中任何一个100%使用Access。
我试过这个，但最终没有成功，因为我不是在处理字符串，我是在处理bmp。
这篇文章让我完成了90%的工作，我可以保存截图并在剪贴板中看到它，但我不知道如何继续。我尝试过其他资源，从HTML构建一个新的电子邮件，但我无法做到这一点。我还尝试过构建一个没有HTML的电子邮件，但最终也无法实现。所以我试着在本地保存文件，然后将其添加到我的电子邮件中，但代码运行时没有错误，但没有保存文件，所以我也遇到了死胡同。
我在这里混合方法，但我会发布我所有的东西，所以它是完整的：
在我的Access数据库中，我有一个表格。我单击一个按钮来获取表格的屏幕截图，然后单击另一个按钮发送我想将屏幕截图粘贴到的电子邮件。我可以使用查询创建电子邮件，但这对我来说不起作用，因为应用于表单的条件格式是关键的，如果它只是一个普通表，我就失去了这一点。最终这一切都将是自动的，按钮只是为了测试。
形式：
访问表单
表单代码：
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 = "user@redacted.com"
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/Paste时，它粘贴到电子邮件中很好，但我无法在初始创建时让VBA执行此操作。SavePicture oPic运行时没有出现错误，但实际上什么也没做。不存在"；没有图像"；弹出的消息。我尝试过定义一个FilePathName，但这也无济于事。
剪贴板中的屏幕截图图片
目前，这段代码生成了一封这样的电子邮件，它删除了我的格式。如果我删除它拉进来的表并点击粘贴，它会带来我的屏幕截图：
期望结果
以下是我使用的所有参考资料
我被困在这里了，我觉得它离工作很近，但我想不通。如有任何帮助，我们将不胜感激，并提前表示感谢。
终于，我开始工作了。这不仅仅是一件有效的事情，还有几件小事，所以我会发布新的代码来完成这项工作。请记住，此代码基于Access表单，其中一个按钮用于截屏，另一个按钮则用于发送电子邮件。它也不完美；它有时会截图屏幕的随机部分，所以我必须点击我的表单，确保它处于活动状态，然后再试一次。我有时也会出现内存错误，屏幕截图会显示在路径中，但它已经坏了。然而，当它真的起作用时，它会很好地工作，我相信所有这些问题都可以解决，所以我将标记这篇文章已经解决。这是我的工作代码，我会在最后记下更改。这是表单本身背后的代码：
Option Compare Database
Option Explicit
Private Sub Command15_Click()
Screenshot.MyPrintScreen ("C:Temptest.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:temptest.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 = "someemailtogoinhere@gmail.com"
oEmail.Subject = "test"
oEmail.Display
'oEmail.Send
Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing
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 "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
突然间，我发现了一个丢失的olepro32.dll的错误。几次扫描后告诉我没有什么问题，我最终不得不将其制作成oleout32.dll，这是朝着正确方向迈出的一步。还要注意的是，为了让img HTML嵌入工作起来，你必须做一些额外的事情，我最终重做了整个部分，并用其他文章中的代码替换了它。
接下来我不得不删除这个部分：
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
我链接的stackoverflow最初说需要保存，但程序的其余部分已经在执行了，这导致了错误。我只是把它完全删除了。我开始将对象设置为"无"以帮助解决记忆问题。