IZBORNIK HOME FORUM ACCESS 2003 EXCEL 2003 WORD 2003  .
   
   
HOME
FORUM Win Tips&Tricks
   
KAKO INSTALIRATI
WINDOWS XP ?
Kako instalirati Win XP sa USB STICKA
Kako instalirati WINDOWS 7 ?
Naučite za 15 minuta raditi u Windows XP
Naučite Internet Explorer i Outlook Express
za 15 minuta
Kako kreirati BOOT CD za instalaciju Win95
   
MS OFFICE 2003
MS OFFICE 2007
   
   
HOME NETWORK
tutorijal za mreže
Network Windows 7 - XP
   
ZANIMLJIVI LINKOVI
BROJEVNI SUSTAVI
(DEC, OKT, BIN, HEX )
CMD - Command Prompt
CISCO - CCNA tutoriali
VLSM and SUBNETTING
   
Tutorijali za phpBB forum
JAVASCRIPT
VISUAL BASIC 6.0
AUTOCAD 2007
 
.
MICROSOFT EXCEL 2007 - Kako poslati emailom više datoteka iz Excela, how to e-mail multiple workbooks from folder via Outlook with VBA

Kako poslati emailom sve datoteke foldera iz Excela
(Excel - Send Workbook via email to multiple recipients)




Kako poslati više Workbook iz mape na više e-mail adresa iz Excela (VBA Macro)

U koliko imate potrebu poslati više datoteka (*.xls, *.xlsx, *.xlsm *.txt *.zip  itd...) iz Excela putem Outlook programa tada možete kreirati VBA makronaredbu koja će vam pomoći slanje svih datoteka (all files) iz foldera tako da svakom imenu bude pridružena određena datoteka koja se nalazi u određenom folderu (mapi)

U ovom primjeru imam situaciju da se u folderu C:\Temp nalazi više datoteka koje treba poslati putem e-maila. Zamislite da imate preko 100 datoteka koje morate svakog tjedna u Ponedjeljak poslati kao izvješće putem e-maila na određene adrese koje nisu iste. Dakle ima više primatelja a određenom primatelju treba poslati određene datoteke. Naravno vi to možete "pješke" odraditi ali će te se naklikati i naklikati.

Da bi izbjegli silno klikanje možemo pripremiti Excel Workbook u kojoj to višestruko slanje možemo odraditi u nekoliko klikova.

Ovaj tutorijal i radnju možemo podijeliti na dva poglavlja.

1. Popisati sve datoteke u folderu C:\Temp u Excel Sheet2
2. Rasporediti datoteke po osobama za slanje u Excel Sheet1

Kako napraviti (kreirati) popis svih datoteka u folderu sa putanjom
(How to make - create a list of all files in a folder with full path )

U prvom koraku trebamo kreirati popis (Listu) svih datoteka koje se nalaze u folderu C:\Temp. Na Sheetu2 kreirajmo tablicu poput ove na slici ispod. Uočite path staze i nazive za svaku datoteku. Ove podatke dobijemo nakon klika na button "Path and Name". Za sada je važno da kreirate tablicu i upišete podatke u ćelije B1 i B2

Kada ste pripremili sve ćelije potrebno je u VBE insertirati New Module i kopirati ovaj Macro

Dim iRow

Sub ListPathNameFiles()
iRow = 5
Call ListMyFiles(Range("B1"), Range("B2"))
End Sub

Sub ListMyFiles(mySourcePath, IncludeSubfolders)
'Obavezno pokrenuti Tools-References i ukljucite opciju Microsoft Scripting Runtime
Set MyObject = New Scripting.FileSystemObject
Set mySource = MyObject.GetFolder(mySourcePath)
On Error Resume Next
For Each myFile In mySource.Files
iCol = 1
Cells(iRow, iCol).Value = myFile.Path
iCol = iCol + 1
Cells(iRow, iCol).Value = myFile.Name
iRow = iRow + 1
Next
If IncludeSubfolders Then
For Each mySubFolder In mySource.SubFolders
Call ListMyFiles(mySubFolder.Path, True)
Next
End If
End Sub

Sada na tekstnom izborniku kliknite na Tools => References i uključite opciju Microsoft Scripting Runtime

Vratite se na Sheet2 u kojem ste kreirali tablicu i dodajte button i pridružite mu Macro. Kliknite na button, sada imate popis svih datoteka u folderu C:\Temp. Uočite da imamo prikazane putanje do datoteka kao i nazive samih datoteka, koje kasnije raznim kombinacijama pomoću funkcija možemo koristiti u daljnjim radnjama. Ako imate i subfoldere (podmape) tada u ćeliji B2 upišite TRUE.

Kako poslati više datoteka na više e-mail adresa putem Outlooka u jednom koraku
(How to send multiple files to multiple (recipients) e-mail address via Outlook in one step)

Sada se prebacimo na Sheet1 u kojem ćemo kreirati tablicu koja sadrži primatelje, njihove e-mail adrese i datoteke koje treba poslati za svaku osobu pojedinačno. Pogledajte sliku ispod

Na slici iznad uočite potrebne podatke koji će biti osnova za slanje višestrukih e-mail poruka putem Microsoft Outlook 2007.
Kako smo dobili ove podatke. Pa popis svih datoteka smo dobili prethodnom makronaredbom, na vama je da ih rasporedite tj. dodijelite primateljima u ćelije u istom redu u kojem se nalazi adresa primatelja.

Na vama je i da upišete imena primatelja u stupcu A kao i e-mail adrese dotičnog primatelja. Kada ste sve podatke upisali, kopirajte ovaj Macro u VBE => New Module pa se vratite se na dotični Sheet1 u kojem ste sredili tablicu i dodajte button i pridružite mu Macro.

Macro za slanje na više e-mail adresa putem e-maila (Microsoft Outlook)

Sub Send_Files()
'
Working in 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set sh = Sheets("Sheet1")
'naziv sheeta u kojem se nalaze podaci za slanje

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'u ovom stupcu B nalaze se naše e-mail adrese

'Enter the file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)

With OutMail
.to = cell.Value
.Subject = "Izvješće za Svibanj 2011"
'predmet poruke za sve poruke će biti isti
.Body = "Pozdrav " & cell.Offset(0, -1).Value

For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell

.Send
'Or use .Display, ako koristite .Display tada ćete morati svaku poruku potvrditi ali imate mogućnost dopisati tekst u poruku
End With

Set OutMail = Nothing
End If
Next cell

Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Pokrenite Microsoft Outlook.
Kliknite na button "Pošalji e-mailom ALL". Pogledajte vaš "Outbox" u MS Outlook-u. Sada u njemu imate onoliko e-mail poruka koliko ste ih pripremili u Excelu. Naravno sada ih možete poslati klikom na Send/Receive.

Ako kliknete dvoklik na neku poruku tada uočite da ista poruka izgleda ovako, pa možete eventualno dopisati neki tekst poruke. Uočite attachment poruke, isti je kao naziv u ćeliji C4 kao na drugoj slici iznad.




PAŽNJA! Vodite računa koliko poruka šaljete u jednom potezu (koraku) jer se može dogoditi da vaš ISP davatelj usluge "cenzurira" slanje jer može smatrati masovno slanje e-mail poruka kao "spam". Zato radnju raskomadajte na nekih 20-tak poruka.


Kako kopirati UNIQUE e-mail adrese i pridružiti im sve FilesName (Transpose data)

Da bi olakšali radnju u slučaju da imate strahovito puno e-mail adresa a na neke e-mail adrese šaljete više različitih Workbook (FilesName) tada iskoristite ovaj Macro koji kopirajte u Module. Na Sheetu "katalog" razvrstavate e-mailove i pridružujete im određene FilesName (ovaj Macro primjenjuje se na drugoj slici ovog tutorijala). Nakon razvrstavanja FilesName po e-mail adresama pozicionirajte se na Sheet1 i pokrenite Macro. Sada su vam kopirani svi jedinstveni e-mailovi a FilesName su transponirani i raspoređeni

Option Explicit
Sub CopyUniqueTranspose()

Dim Cell As Range
Dim Data As Variant
Dim Dict As Object
Dim DstRng As Range
Dim Key As Variant
Dim Item As Variant
Dim R As Long
Dim Rng As Range
Dim RngEnd As Range
Dim Wks As Worksheet

Set Wks = Worksheets("katalog")
'izvorni Sheet na kojem smo izvršili raspored e-mailova i FilesName
Set Rng = Wks.Range("A1")
'prvi podatak
Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))

Set DstRng = Worksheets("Sheet1").Range("B2")
'destinacija gdje kopiramo prvi e-mail

Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare

For Each Cell In Rng
Key = Trim(Cell)
Item = Array(Cell.Item(1, 2))
If Not Dict.Exists(Key) Then
Dict.Add Key, Join(Item, "|")
Else
Dict(Key) = Dict(Key) & "|" & Join(Item, "|")
End If
Next Cell

For Each Key In Dict.Keys
With DstRng.Offset(R, 0)
.Value = Key
Data = Split(Dict(Key), "|")
.Offset(0, 1).Resize(1, UBound(Data) + 1).Value = Data
R = R + 1
End With
Next Key
End Sub



DOWNLOAD datoteke iz ovog primjera

Vezani linkovi:

- Kako poslati Workbook e-mailom i službeni potpis u e-mailu
- Kako poslati Active Sheet e-mailom na adresu u ćeliji





©- 2006 - 2021 - IvanC  - Sva prava pridržana.  ic.ims.hr