Jag undrar över hur jag skall göra för att kunna skriva ut ett PDF-dokument och automatiskt skicka det som en epostbilaga. Det finns en funktion i vb6 som heter printer.print - kolla om du inte kan använda detta. När det gäller att skicka det som mail så finns även ett objekt cdo.message för detta att lägga in ett attachment i ett mail och skicka det.Utskrift av PDF-dokument i VB6
Dokumentnamn och adressat hämtas från applikationen.
Tacksam för tipsSv: Utskrift av PDF-dokument i VB6
Public Function SendNewLetters(ByVal PathForLetters As String, ByVal FromName As String, ByVal FromEmail As String, ByVal ToName As String, _
ByVal ToEmail As String, ByVal SMTPServer As String, ByVal SMTPPort As Long, ByVal SMTPUser As String, _
ByVal SMTPPassword As String, Optional ByVal UseSSL As Boolean = False, Optional ByRef ErrorCode As Long = 0, _
Optional ErrorDesc As String = vbNullString) As Boolean
On Error GoTo ErrorHandler
Const CdoReferenceTypeName = 1
Dim iMsg As CDO.Message ' Not using CreateObject() because I have the reference added
Dim sFileCID As String, sFileExt As String
Dim sIconImageSrc As String, sIconImageCID As String
Dim iBpAttachment As CDO.IBodyPart ' Will be reused more than once
Dim iBpIconImage As CDO.IBodyPart
Dim oFSO As Scripting.FileSystemObject
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oDictAddedExtIcons As Scripting.Dictionary
Set iMsg = New CDO.Message
' Configure SMTP parameters
With iMsg.Configuration
.Fields(cdoSMTPServer) = SMTPServer
.Fields(cdoSMTPServerPort) = SMTPPort
.Fields(cdoSMTPUseSSL) = UseSSL
.Fields(cdoSMTPAuthenticate) = cdoBasic
.Fields(cdoSendUserName) = SMTPUser
.Fields(cdoSendPassword) = SMTPPassword
.Fields(cdoSMTPConnectionTimeout) = 60
.Fields(cdoSendUsingMethod) = cdoSendUsingPort
.Fields.Update
End With
' Set From and To fields
If Len(FromName) > 0 Then
' Let's say we already QP-encoded any special chars for the name
' and checked the email address
iMsg.From = FromName & " <" & FromEmail & ">"
Else
iMsg.From = FromEmail
End If
If Len(ToName) > 0 Then
' Same thing here
iMsg.To = ToName & " <" & ToEmail & ">"
Else
iMsg.To = ToEmail
End If
' Set subject (would need QP encoding as well)
iMsg.Subject = "Additional Replacement Letters : " & Format(Now, "mm/dd")
' Build the body
iMsg.HTMLBody = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional //EN""><html><body><p>Hello Team,<br/><br/>" & _
"Please find below the attached letters</p><div style=""display: table"">"
' Will be used to make sure icon images are only added once
Set oDictAddedExtIcons = New Scripting.Dictionary
' Add files here, one new body part for each
Set oFSO = New Scripting.FileSystemObject
If oFSO.FolderExists(PathForLetters) Then
Set oFolder = oFSO.GetFolder(PathForLetters)
For Each oFile In oFolder.Files
' IMPORTANT: Content-IDs should not contain spaces
sFileCID = Replace$(oFile.Name, " ", "_")
Set iBpAttachment = iMsg.AddRelatedBodyPart(oFile.Path, oFile.Name, CdoReferenceTypeName)
iBpAttachment.Fields.Item("urn:schemas:mailheader:content-id") = "<" & sFileCID & ">"
iBpAttachment.Fields.Update ' Dont' forget that line
sFileExt = LCase$(GetFileExtension(oFile.Name))
sIconImageSrc = vbNullString
Select Case sFileExt
Case "doc"
' We provide here the path to a 32x32 image of the doc file icon
sIconImageSrc = "C:\Users\MyUserName\Desktop\DocIcon.png"
' We could also provide images for other extensions, or
' (more involved) query the DefaultIcon for any extension from
' the registry, load the icon from the ico/exe/dll file and
' find the best size/resize if necessary (already have the
' code, but it's a *lot* of code).
Case ".."
' Add support for more
End Select
If Len(sIconImageSrc) > 0 Then
If Not oDictAddedExtIcons.Exists(sFileExt) Then
sIconImageCID = GetFilePart(sIconImageSrc) ' Is the filename for this and the next line
Set iBpIconImage = iMsg.AddRelatedBodyPart(sIconImageSrc, sIconImageCID, CdoReferenceTypeName)
' IMPORTANT: Content-IDs should not contain spaces
sIconImageCID = Replace$(sIconImageCID, " ", "_")
iBpIconImage.Fields.Item("urn:schemas:mailheader:content-id") = "<" & sIconImageCID & ">"
iBpIconImage.Fields.Update ' Dont' forget that line
oDictAddedExtIcons.Add sFileExt, sIconImageCID
sIconImageSrc = "cid:" & sIconImageCID
Else
sIconImageSrc = "cid:" & oDictAddedExtIcons.Item(sFileExt)
End If
End If
iMsg.HTMLBody = iMsg.HTMLBody & "<div style=""display: table-row""><div style=""text-align: left; " & _
"vertical-align: middle; margin-right: 10px;"">"
If Len(sIconImageSrc) > 0 Then
iMsg.HTMLBody = iMsg.HTMLBody & "
"
Else
iMsg.HTMLBody = iMsg.HTMLBody & " "
End If
iMsg.HTMLBody = iMsg.HTMLBody & "</div><div style=""display: table-cell; text-align: left; vertical-align: middle;"">"
iMsg.HTMLBody = iMsg.HTMLBody & "" & oFile.Name & ""
iMsg.HTMLBody = iMsg.HTMLBody & "</div></div>"
Next
End If
iMsg.HTMLBody = iMsg.HTMLBody & "</div><br/>"
iMsg.HTMLBody = iMsg.HTMLBody & "<p>Revert to me for any concerns.</p></body></html>"
' Send away!
iMsg.Send
SendNewLetters = True
Exit Function
ErrorHandler:
ErrorCode = Err.Number
ErrorDesc = Err.Description
SendNewLetters = False
End Function
Public Function GetFilePart(ByVal FilePath As String) As String
Dim lPos As Long
lPos = InStrRev(FilePath, "\")
If lPos > 0 Then
GetFilePart = Right$(FilePath, Len(FilePath) - lPos)
End If
End Function
Public Function GetFileExtension(ByVal FilePath As String, Optional ByVal WithDot As Boolean = False) As String
Dim lPos As Long
lPos = InStrRev(FilePath, ".")
If InStr(1, FilePath, ".") Then
If WithDot Then
GetFileExtension = Right$(FilePath, Len(FilePath) - lPos + 1)
Else
GetFileExtension = Right$(FilePath, Len(FilePath) - lPos)
End If
End If
End Function