outlook'ta gelen mail ekini otomatik yazdırma makrosu

[Korhan Ayhan]

Bildiğiniz gibi her dosyanın sonunda hangi dosya türü olduğuna dair bir uzantısı vardır.

Bu uzantı genellikle 3-4 karakter uzunluğundadır.

Murat bey kullandığı komutla o uzantıyı tespit ediyor.

Benim verdiğim kod bloğundaki bu uzantı karakter uzunluğuna bakılmadan tespit ediliyor. Yani biraz daha esnek bir kullanım şeklidir.

Bu filtre yazdırmak istemediğiniz bir dosya mail olarak geldiğinde bunu elemek adına kullanılıyor. Yani bir nevi hedefe yönelik bir kod satırıdır.

PDF dosyasının ilk sayfasını yazdırmak için sisteminizde Adobe Acrobat yüklü olması avantaj sağlayacaktır.

 

[mozcakir]

ilk kullandığım kod bu şekildeydi


Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder

Set Ns = Application.GetNamespace("MAPI")
Set Folder = Ns.GetDefaultFolder(olFolderInbox)
Set Items = Folder.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
PrintAttachments Item
End If
End Sub

Private Sub PrintAttachments(oMail As Outlook.MailItem)
On Error Resume Next
Dim colAtts As Outlook.Attachments
Dim oAtt As Outlook.Attachment
Dim sFile As String
Dim sDirectory As String
Dim sFileType As String

sDirectory = "C:\Outlook"

Set colAtts = oMail.Attachments

If colAtts.Count Then
For Each oAtt In colAtts

sFileType = LCase$(Right$(oAtt.FileName, 4))

Select Case sFileType
Case ".xls", ".doc", ".pdf"
sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
oAtt.SaveAsFile sFile
ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
End Select
Next
End If
End Sub


sonrasında da bu kodu kullandım

Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Set Ns = Application.GetNamespace("MAPI")
Set Folder = Ns.GetDefaultFolder(olFolderInbox)
Set Items = Folder.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
PrintAttachments Item
End If
End Sub

Private Sub PrintAttachments(oMail As Outlook.MailItem)
On Error Resume Next
Dim colAtts As Outlook.Attachments
Dim oAtt As Outlook.Attachment
Dim sFile As String
Dim sDirectory As String
Dim sFileType As String

sDirectory = "C:\Outlook"

Set colAtts = oMail.Attachments

If colAtts.Count Then
If oMail.SenderEmailAddress = "muharrem_ozcakir@hotmail.com" Then
For Each oAtt In colAtts
sFileType = UCase(CreateObject("Scripting.FileSystemObject").GetExtensionName(oAtt.FileName))
Select Case sFileType
Case "PDF"
sFile = sDirectory & oAtt.FileName
oAtt.SaveAsFile sFile
ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
End Select
Next
End If
End If
End Sub




kullanmış olduğum kod aslında bu şekilde ancak run dediğim halde herhangi bir tepki alamıyorum makro güvenliğinde ki ayarlarım ise tüm makrolara izin ver seçeneği ekli ancak yine de herhangi bir tepki alamadım

 

[Korhan Ayhan]

Bu kod run edilecek bir kodlama değildir.

Doğru uyguladıysanız her yeni mail geldiğinde otomatik çalışacak şekilde tasarlanmış bir kodlamadır.

 

[mozcakir]

gönderdiğim her iki farklı kodu uygulasam da çalışması gerekiyor sanırım

 

[mozcakir]

Tekrar Merhabalar outlook a mailleri gönderdim ancak herhangi bir tepki olmadı sizlerden rica size bir any desk veta team viewer numarası versem bunun üzerinden bana yardımcı olabilir misiniz veya telefon üzerinden de görüşebiliriz

 

[mozcakir]

Tekrar Merhabalar az önce bir video buldum ve bulduğum video da vba paneline bir kod yapıştırıldı ve sonrasında kural oluşturuldu oluşturulan kural sonucu pdf eklerimiz çıktı olarak geldi ancak kodlama ile alakalı bilgim olmadığı için bir sorum var çıktılar a4 sayfası için çıktı biz a5 kağıt kullanıyoruz ayrıca pdf ekinin (a5 kullandığımız için) sadece ilk sayfasını yazdırıyoruz bununla ilgili yardımcı olabilir misiniz

video linki:

videonun altında bulunan bir kullanıcıya ait güncellenmiş kodlar bende çalışan kodlar bunlar;

Sub AttachmentPrint(Item As Outlook.MailItem)

On Error GoTo OError

' This script finds the system's Temp folders,
' saves any attachments, and runs the Print
' command for that file.

Dim oFS As FileSystemObject
Dim sTempFolder As String
Set oFS = New FileSystemObject
sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)

sTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
MkDir (sTmpFld)

' in the next few lines, you'll see an entry that
' says FileType = . This line gets the last 4
' characters of the file name, which we'll use later.

Dim oAtt As Attachment
For Each oAtt In Item.Attachments
FileName = oAtt.FileName
FileType = LCase$(Right$(FileName, 4))
FullFile = sTmpFld & "\" & FileName
oAtt.SaveAsFile (FullFile)

' We're using the FileType text. Note that it's the
' last 4 characters of the file name, which is why
' the next chunk has .xls and xlsx (without the period)
' - the period counts as the fourth character.

Select Case FileType
Case ".doc", "docx", ".xls", "xlsx", ".ppt", "pptx", ".pdf", ".tif"
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(0)
Set objFolderItem = objFolder.ParseName(FullFile)
objFolderItem.InvokeVerbEx ("print")
End Select
Next oAtt

If Not oFS Is Nothing Then Set oFS = Nothing
If Not objFolder Is Nothing Then Set objFolder = Nothing
If Not objFolderItem Is Nothing Then Set objFolderItem = Nothing
If Not objShell Is Nothing Then Set objShell = Nothing

OError:
If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
Err.Clear
End If

Exit Sub
End Sub

 

[mozcakir]

son olarak kuralı ilk çalıştır dediğimde çalışıyor yazdırıyor ancak ikinci defa çalıştır dediğimde Error 75 - Path/File access hatası alıyorum bununla da ilgili yardımcı olabilirseniz çok teşekkür ederim

 

[Korhan Ayhan]

Başka bir başlıkta PDF dosyasında istenen sayfanın yazdırılması ile ilgili bir konu işlemiştik.

PDF'ten Sayfa Yazdırma

Öncelikle herkese merhaba, Excel dosyamda A1 hücresinde yazan değer (111) PDF dosyamın ismi, B1 hücresinde yazan değer (10) ise PDF dosyamdaki sayfa numarası. Örneğin, makroya tıkladığımda "111.pdf" isimli dosyanın, 10. Sayfadan 2 adet çıktı alsın istiyorum. Nasıl yapılabilir

www.excel.web.tr

 

[mozcakir]

Tekrar Merhabalar son olarak kuralı ilk çalıştır dediğimde çalışıyor yazdırıyor ancak ikinci defa çalıştır dediğimde Error 75 - Path/File access hatası alıyorum ayrıca yeni bir mail geldiğinde de 424 object required hatası ortaya çıkıyor bununla da ilgili yardımcı olabilirseniz çok teşekkür ederim

 

[Korhan Ayhan]

Kodu adım adım çalıştırıp hata veren satırı tespit etmelisiniz. Bu şekilde yardımcı olamam.

 

[mozcakir]

anlıyorum çok teşekkür ederim desteğiniz için