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 radni list e-mailom na adresu u ćeliji, How to send a worksheet via e-mail in the cell, VBA

Kako poslati aktivni radni list e-mailom na adresu u ćeliji
(How to send a active worksheet via e-mail in the cell)






Slanje aktivnog radnog lista iz Excela putem Outlook e-maila na adresu u ćeliji

U koliko imate potrebu poslati aktivni radni list (Sheet) putem e-maila osobi čiju adresu želite upisati u nekoj ćeliji na aktivnom radnom listu tada iskoristite ovaj Macro ispod. Kopirajte Macro u VBE Module

U ćeliju A1 upišite e-mail adresu osobe kojoj želite poslati aktivni Sheet. Ako imate više radnih listova koje trebate poslati na više različitih e-mail adresa tada u svaki radni list u A1 ćeliju upišite e-mail adresu dotične osobe primatelja. Ako je problem ćelija A1 (iskorištena u tablici) tada e-mail adresu upišite u neku drugu ćeliju ali tada ispravite dio koda u makronaredbi.

Kada ste spremni za slanje Sheeta i kada se se pozicionirate na aktivni radni list pokrenite makronaredbu (ALT+F8). Prije nego pokrenete makronaredbu za slanje pokrenite MS Outlook. Nemojte kreirati button jer će se i dotični button poslati u Sheetu.

Option Explicit

Sub MailAddressActiveSheet()
'Working in 2000-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet

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

Set Sourcewb = ActiveWorkbook

'kopira sheet u novu workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Izjvjesce2011 " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

For Each ws In ActiveWorkbook.Worksheets
If ws.Range("
A1").Value Like "?*@?*.?*" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = ws.Range("
A1").Value
'.CC = ""
'.BCC = ""

.Subject = "Izvješće za 2011"
.Body = "Pozdrav, šaljem vam izvješće za mjesec svibanj 2011"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\Temp\datoteka.txt")

.Send 'ili upotrijebi .Display ako zelis dodatno editirati email poruku
End With
On Error GoTo 0
.Close savechanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next ws

End Sub

Ako želite dodatno editirati BODY tekst u samoj poruci tada umjesto .Send upotrebite naredbu .Display



Slanje aktivnog radnog lista iz Excela putem e-maila na više adresa  preko Outlook-a

Ako želite striktno odrediti više e-mail adresa na koje šaljete i one su uvijek iste tada iskoristite ovaj macro ispod. U samoj makronaredbi definirajte e-mail adrese na koje šaljete aktivni radni list (kao attachment).

Option Explicit

Sub Mail_ActiveSheet()
'Working in 2000-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

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

Set Sourcewb = ActiveWorkbook

'kopira sheet u novu workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Izjvjesce2011 " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.TO = "IME1@mail.com"
.CC = "IME2@mail.com, IME3@mail.com"
'točka-zarez ili zarez između adresa ??
.BCC = ""
.Subject = "Izvješće za 2011"
.Body = "Pozdrav, šaljem vam izvješće za mjesec svibanj 2011"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\Temp\datoteka.txt")

.Send 'ili upotrijebi .Display ako zelis dodatno editirati email poruku
End With
On Error GoTo 0
.Close savechanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub



Ako želite dodatno editirati BODY tekst u samoj poruci tada umjesto .Send upotrijebite naredbu .Display

Kada ste završili slanje iz Excela na vama ostaje samo još da kliknete na Send/Receive u Outlooku. Također pogledajte primjer Kako poslati Workbook i Signature iz Excela kao i Kako poslati više XLS datoteka na više e-mail adresa





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