Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > Diğer Yazılımlar > Windows-Word-PowerPoint....
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Windows-Word-PowerPoint.... Excel haricindeki Ofis programları ile ilgili konular.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 27-11-2017, 23:28   #1
ADEMES
 
Giriş: 05/01/2010
Şehir: izmir
Mesaj: 123
Excel Vers. ve Dili:
2013
Exclamation outlook değişken mail başlığı

Selamlar ,

outlookta otomatik olarak gönderilen her mail için artan bir referans numarası verilsin ve yanınada tarih atılsın. Bu detaylar mailin en üst kısmına otomatik olarak koyulsun.

örnek : Ref AE-001 ( her mailde artacak )

bu giden mailler başka bir excel dosyasına baslık , kime , saat detayıyla kayıt edilsin.

saygılarımla
adem
ADEMES Çevrimdışı   Alıntı Yaparak Cevapla
Eski 28-11-2017, 09:05   #2
ADEMES
 
Giriş: 05/01/2010
Şehir: izmir
Mesaj: 123
Excel Vers. ve Dili:
2013
Varsayılan

Aşağıda ki gibi bir macro buldum ama sadece Ref-1 Atıyor.

bunu Ref: 1000001.AE 2017/11/27 16.47 şeklinde yapabilir miyiz.

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Const strWorkbook As String = "C:\MessageLog\MessageLog.xlsx" 'The workbook to store the data
Const strPath As String = "C:\MessageLog\" 'The folder to store the data
Const strFields As String = "RefNo|Date|Time|MessageTo|Subject" 'The fields to store the data

Dim strValues As String
Dim iStartNum As Long
Dim strSubject As String
Dim strDate As String
Dim strTime As String
Dim strRecipient As String
If Not FileExists(strWorkbook) Then
CreateFolders strPath
xlCreateBook strWorkbook, strFields
iStartNum = 0 ' One less than the first number to record.
Else
iStartNum = xlGetNextNum(strWorkbook)
End If
strSubject = Item.Subject
strRecipient = Item.To
strDate = Format(Date, "dd/MM/yyyy")
strTime = Format(Time, "HH:MM")

'Write the value of iStartNum + 1 wherever you want it - here at the end of the subject.
Item.Subject = strSubject & " - Ref: " & CStr(iStartNum + 1)

strValues = CStr(iStartNum + 1) & "', '" & _
strDate & "', '" & _
strTime & "', '" & _
strRecipient & "', '" & _
strSubject
Item.Save
WriteToWorksheet strWorkbook, "Sheet1", strValues
lbl_Exit:
Exit Sub
End Sub

Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
Dim CN As Object
Dim ConnectionString As String
Dim strSQL As String

ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

Private Function xlGetNextNum(strWorkbook As String) As Long
Dim RS As Object
Dim CN As Object
Const strWorksheetName As String = "Sheet1$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12 .0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
xlGetNextNum = .Fields(0)
End With
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

Private Sub xlCreateBook(strWorkbook As String, strTitles As String)
Dim vValues As Variant
Dim xlApp As Object
Dim xlWB As Object
Dim bStarted As Boolean
Dim i As Long

vValues = Split(strTitles, "|")
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bStarted = True
End If
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Add
With xlWB.Sheets(1)
For i = 0 To UBound(vValues)
.Cells(1, i + 1) = vValues(i)
Next i
End With
xlWB.SaveAs strWorkbook
xlWB.Close 1
If bStarted Then
xlApp.Quit
Set xlApp = Nothing
Set xlWB = Nothing
End If
lbl_Exit:
Exit Sub
End Sub

Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
ADEMES Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 20:21


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım -- Beylikdüzü mali müşavir - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Dil Konuşma Terapisti- Çorlu Özel Eğitim- Site Yönetimi- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Çorlu- Çorlu Araç Takip- Çorlu Su Arıtma- Gebze Emlak- Rampa- Rotary- Çorlu İnternet Sitesi- Çorlu Sürücü Kursu- Çorlu Sürücü Kursu- Şişli Avukat- Edirne Serbest Muhasebeci- Çorlu Etüt- İstanbul Botanik- Çorlu Sigorta- Kağıt Bardak- Kaplan Tekstil- Çorlu Perde- Çorlu Havuz- Makina- Danışmazlar-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden