SAYFALARI AYRI AYRI Klasöre Kaydetme

[muzos80]

Güncel

 

[muzos80]

Halen çözemedim

 

[muzos80]

Birilerin işine yarar aşağıdaki kod ile sorunu çözdüm Necati ustama da teşekkür ederim

Application.DisplayAlerts = False
Set nesne = CreateObject("Scripting.FileSystemObject")
Yol = "\\DENEME"
klasoradi = ActiveWorkbook.Sheets("FORM").Cells(5, 2).Text
dosyaadi = ActiveWorkbook.Sheets("FORM").Cells(5, 2).Text
klasorara = nesne.FolderExists(Yol & "\" & klasoradi)
If klasorara = False Then nesne.CreateFolder Yol & "\" & klasoradi


ActiveSheet.Copy
With ActiveWorkbook
ActiveWorkbook.SaveAs Filename:=Yol & "\" & klasoradi & "\" & dosyaadi & ".xlsx", FileFormat:=xlOpenXMLWorkbook

.Close
End With
Worksheets("ARŞİV").Select
sonsat = Worksheets("ARŞİV").Range("K" & 65536).End(xlUp).Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Yol & "\" & klasoradi & "\" & dosyaadi & ".xlsx", TextToDisplay:=Yol & "\" & klasoradi & "\" & dosyaadi & ".xlsx"

 

[muzos80]

Merhaba Bir eklenti yapabilirmiyim Arşiv sayfasına veri kaydedildiğinde son kayıt edileni, bilirli 10 kişiye outlook 2016 ve üzerinde çalışacak otomatik toplu mail gönderimi yapabilirmiyiz

 

[necati]

Merhaba,
Kaydedilen "Form" sayfasını ek olarak koyduğunuz bir mail gönderilecek değil mi?
Gönderilecek kişilerin mail adreslerini manuel mi gireceksiniz, sayfadaki bir aralıktan mı alacaksınız?

 

[muzos80]

Arşiv sayfasını gönderecek yada Arşiv sayfasına eklediği son verileri B den K ya kadar olanını mail atmasını istiyorum yani bilgi maili olacak

 

[muzos80]

Gönderilecek kişilerin mail adrslerini makroda yazılı olması daha iyi olur

 

[necati]

Arşiv sayfasındaki son satırı mail atmak için olan kodlar şöyle:

Sub SeciliAlaniMailAtmak()
'Exceldeki seçili bir alanı mail gövdesine yapıştırıp mail atar..
Dim oOutlookApp As Object
Dim oItem As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim xlRng As Range

Set oOutlookApp = CreateObject("Outlook.Application")
Set oItem = oOutlookApp.createitem(0)
sons = Worksheets("ARŞİV").Cells(Rows.Count, "K").End(3).Row
Set xlRng = Worksheets("ARŞİV").Range("B" & sons & ":K" & sons)
xlRng.Copy

    With oItem
        .display
        .BodyFormat = 2
        .To = "filanca@mail.com.tr;filanca@mail.com.tr"  'Diğer mail adreslerini buraya eklemelisiniz
        .Subject = "Ekli satırların gönderimi"           'Konu yazılacak yer
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.collapse 1
        oRng.Text = "Mail gövdesine yazmak istediğin cümle varsa buraya yaz" & vbCr 
        oRng.collapse 0
        oRng.Paste
        oRng.collapse 0
        oRng.Text = vbCr & "Mail gövdesi sonuna yazmak istediğin cümle varsa buraya yaz"
    End With

    Set oItem = Nothing
    Set oOutlookApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set xlRng = Nothing
End Sub

 

[muzos80]

Süpersin çok teşekkür ederim iş yerine gidince deneyeceğim

 

[muzos80]

Başarılı oldu istediğim gibi ama Gönderme ekranında kaldı gönderme yapamadı yada bizde şirket içi diye seçme yapmamız gerekiyor ondan dolayı da olabilir

 

[necati]

Send komutunu bilerek koymamıştık. Belki ön izleme yapmak gerekir diye. Ama şimdi koyalım.
.Send 'Bu satır gönderir. İsterseniz yine pasif yaparsınız.
Bir de gönderilen satırı başlıksız almışız. Başlık konursa daha anlaşılır olur gibi. Şimdiki kodda başlık da ekleniyor.

Sub SeciliAlaniMailAtmakYenison()
'Exceldeki sayfadaki son satırı mail gövdesine yapıştırıp mail atar..
'Satır başlıkları da dahil edildiler.
Dim oOutlookApp As Object, oItem As Object, olInsp As Object
Dim wdDoc As Object, oRng As Object
Dim xlRng As Range
Dim SonS As Long

Set oOutlookApp = CreateObject("Outlook.Application")
Set oItem = oOutlookApp.createitem(0)
SonS = Worksheets("ARŞİV").Cells(Rows.Count, "K").End(3).Row

    With oItem
        .display
        .BodyFormat = 2
        .To = "filanca@mail.com;filanca@mail.com"
        .Subject = "Ekli satırların gönderimi"
Set xlRng = Worksheets("ARŞİV").Range("B7:K7")
xlRng.Copy
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.collapse 1
        oRng.Text = "Mail gövdesine yazmak istediğin cümle varsa buraya yaz" & vbCrLf & " "
        oRng.collapse 0
        oRng.Paste

Set xlRng = Worksheets("ARŞİV").Range("B" & SonS & ":K" & SonS)
xlRng.Copy
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.collapse 0
        oRng.Text = " " & vbCrLf & " " & vbCrLf & "Mail gövdesi sonuna yazmak istediğin cümle varsa buraya yaz"
        oRng.Paragraphs(1).Range.Paste
        Application.CutCopyMode = False
        .Send
    End With

    Set oItem = Nothing
    Set oOutlookApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set xlRng = Nothing
End Sub

 

[muzos80]

Oldu ama bizde gönder dedikten sonra şirket içi yada dışı seçenekleri veriyor outlook orda kalıyor ama çıkan uyarıyada cancel denildiğinde yine de gönderiyor eline sağlık çok teşekkür ederim

 

[necati]

Şirket içi yada dışı seçenekleri konusunda bilgim yok ama kodun işe yaramasına memnun oldum.