ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[Ceryanci33]

Arkadaşlar merhaba, aranızda çok yeniyim. Farklı bir sektörde çalıştığım için programlama bilgim maalesef yok. Bir excel dosyam var. Bu excel dosyasının belli hücrelerini ayrı kitap olarak oluşturup mail olarak göndermek için buton ekledim. Forumdan bulduğum kodu kullanarak mail attırabiliyorum. Fakat üç adet ekleme yapmam lazım.
Birincisi mailin kime gönderileceği sabit olduğu için kod içine eklemem lazım.
İkincisi excel sayfasında değişiklik yapılmaması için bazı hücreleri kilitleyip parola koydum. Sayfa kilitli olduğu zaman mail butonu çalışmıyor. Sayfa kilitli uyarısı veriyor. Bunu düzeltmem lazım.
Üçüncüsü mail olarak atmak istediğim hücre alanında başka makro butonları var. Maile onlar dahil olmuyor. Onları da dahil etmek istiyorum.
Çok fazla oldu biliyorum ama yardımcı olabilirseniz çok sevinirim.

[Ceryanci33]

Soruda bahsettiğim kod aşağıdadır.

Sub mail_gonder()
Range("AV1:BI12").Select
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long
Set Source = Nothing
On Error Resume Next
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox " Bir hata oluştu:" & vbNewLine & vbNewLine & _
"Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name & " " & Format(Now, "dd-mm-yyyy h-mm-ss")
If Val(Application.Version) < 12 Then
'Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
For I = 1 To 3
.SendMail "", _
"Günlük Faaliyet Raporu"
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

[Yken]

1. Sayfa kilitli uyarısı
2. butonlar dahil olmuyor
3. mailin kime gönderileceği
Açıklamalar kod içinde büyükharflerle yapıldı.

Kod: Tümünü seç

Sub mail_gonder()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long

Range("A1:B12").Select
Set Source = Nothing
On Error Resume Next
'1. BURASI SAYFA KORUMAYI KALDIR VE TEKRAR KOY
ActiveSheet.Unprotect Password:="" 'ŞİFRE VARSA AYARLA
Set Source = Selection.SpecialCells(xlCellTypeVisible)
ActiveSheet.Protect
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox " Bir hata oluştu:" & vbNewLine & vbNewLine & _
"Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Paste '2. BURASI SEÇİLİ ALANDAKİ BUTONLARI DA KOPYALAR/YAPIŞTIRIR
.Cells(1).PasteSpecial Paste:=xlPasteAll
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
     
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name & " " & Format(Now, "dd-mm-yyyy h-mm-ss")
If Val(Application.Version) < 12 Then
'Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
For I = 1 To 3
'3. BURASI GÖNDERİLECEK MAİL ADRESİDİR
.SendMail "Ceryanci33@Gmail.com", _
"Günlük Faaliyet Raporu"
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


[Ceryanci33]

Hocam ilginiz için öncelikle çok teşekkür ederim. Kodu çalıştırınca bir kaç hata alıyorum.
1. Excel de belirlediğim alan ayrı bir excel kitabı olarak oluşuyor fakat yeni kitaptaki hücrelerin içine veriler gelmiyor.
2. Yeni oluşan kitap outlook a otomatik yüklenmiyor.
3. Butonlar kopyalanıyor. Butonların işlevi belli excel satırlarını kopyalamaktı. Yeni kitapta satır isimleri değiştirği iöin butonlar çalışmıyor.. Birde aynı anda birden fazla kişiye mail atmak için ikinci mail adresini nasıl ekleyebiliriz koda acaba.
Excel dosyamı ekliyorum.

[Yken]

Kod: Tümünü seç

Sub mail_gonder()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long

Range("AS1:BI12").Select
Set Source = Nothing
On Error Resume Next
'1. BURASI SAYFA KORUMAYI KALDIR VE TEKRAR KOY
ActiveSheet.Unprotect Password:="2023" 'ŞİFRE VARSA AYARLA
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox " Bir hata oluştu:" & vbNewLine & vbNewLine & _
"Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Paste '2. BURASI SEÇİLİ ALANDAKİ BUTONLARI DA KOPYALAR/YAPIŞTIRIR
.Cells(1).PasteSpecial xlPasteValuesAndNumberFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
ActiveSheet.Protect
     
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name & " " & Format(Now, "dd-mm-yyyy h-mm-ss")
If Val(Application.Version) < 12 Then
'Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
If IsNull(Application.MailSession) Then
    Application.MailLogon
End If

For I = 1 To 3
'3. BURASI GÖNDERİLECEK MAİL ADRESİDİR
.SendMail Array("Ceryanci33@Gmail.com", "Ceryanci34@Gmail.com", "Ceryanci35@Gmail.com"), _
"Günlük Faaliyet Raporu"
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


[Yken]

Şu satırlar buraya ait değil, bunları siliniz.

Kod: Tümünü seç

If IsNull(Application.MailSession) Then
    Application.MailLogon
End If


[Ceryanci33]

Hocam çok sağolun, bir tek sonunum kalmış. Aktarılan butonlar başka bir yeri kopyalıyor. Hangi satırı kopyalaması gerektiğini boyadım. Birde yeni kitaptaki hücre boyutları orijinalinden farklı bunu ayarlayabilir miyiz?

[Yken]

Dostum butonların bağlı olduğu makrolara müdahale etmedik ki yanlış yeri kopyalıyor olsunlar.
Ama sütun genişlikleri için ilave yapıldı. Bir de sayfa koruma ve açmada bir hata vardı giderildi.

Kod: Tümünü seç

Sub mail_gonder()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook, ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long

Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Range("AS1:BI12").Select
Set Source = Nothing
On Error Resume Next
'1. BURASI SAYFA KORUMAYI KALDIR VE TEKRAR KOY
ws.Unprotect Password:="2023" 'ŞİFRE VARSA AYARLA
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
    MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
    Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
    Selection.Cells.Count = 1 Or _
    Selection.Areas.Count > 1 Then
    MsgBox " Bir hata oluştu:" & vbNewLine & vbNewLine & _
    "Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
    Exit Sub
End If
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
    .Paste '2. BURASI SEÇİLİ ALANDAKİ BUTONLARI DA KOPYALAR/YAPIŞTIRIR
    .Cells(1).PasteSpecial xlPasteValuesAndNumberFormats
    .Cells(1).PasteSpecial xlPasteColumnWidths   '4. BURASI SÜTUN GENİŞLİKLERİNİ ORJİNALİ GİBİ KOPYALAR
    .Cells(1).Select
Application.CutCopyMode = False
End With
ws.Protect
     
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name & " " & Format(Now, "dd-mm-yyyy h-mm-ss")
If Val(Application.Version) < 12 Then
    'Excel 2000-2003
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    'Excel 2007-2010
    FileExtStr = ".xlsx": FileFormatNum = 51
End If
With Dest
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    For I = 1 To 3
        '3. BURASI GÖNDERİLECEK MAİL ADRESİDİR
        .SendMail Array("Ceryanci33@Gmail.com", "Ceryanci34@Gmail.com", "Ceryanci35@Gmail.com"), _
        "Günlük Faaliyet Raporu"
        If Err.Number = 0 Then Exit For
    Next I
    On Error GoTo 0
    .Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub


[Ceryanci33]

Hocam doğru diyorsunuz ama mesela birinci kopyalama butonu orijinal dosyada AX4:BH4 arasını kopyalıyor ki öyle olmasını istiyorum. Fakat mail gönderilince sayfa farklı hücrelere yerleştiği için kopyalamak istediğim hücreler F4:P4 olması gerekiyor. Bunu çözemedim.

[Yken]

Şimdi bu dosyayı ek olarak karşı tarafa göndereceksiniz ve düğmelere tıklayıp makroları çalıştıracak olan kişi karşı taraf olacak. Doğru mu anlamışım?
Eğer doğru ise dosyayı makro etkin çalışma kitabına dönüştürerek kaydetmeliyiz.
Ayrıca ilgili makroları da içine eklemeliyiz.
Kopyalama koordinatları değişmesin diye kaynak kitaptaki aynı koordinatı baz alarak yeni kitabı oluşturalım.

Kod: Tümünü seç

Sub mail_gonder_Modulile()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook, ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim strTempFile As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long

Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

strTempFile = Environ$("temp") & "\" & "~tmpexport.bas"
wb.VBProject.VBComponents("Module2").Export strTempFile 'modülü dışarı al

Range("AS1:BI12").Select
Set Source = Nothing
On Error Resume Next
'1. BURASI SAYFA KORUMAYI KALDIR VE TEKRAR KOY
ws.Unprotect Password:="2023" 'ŞİFRE VARSA AYARLA
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
    MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
    Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
    Selection.Cells.Count = 1 Or _
    Selection.Areas.Count > 1 Then
    MsgBox " Bir hata oluştu:" & vbNewLine & vbNewLine & _
    "Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
    Exit Sub
End If
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
    .Range("AS1").Select
     ActiveWindow.Zoom = 55
     ActiveWindow.ScrollColumn = Selection.Column
    .Paste '2. BURASI SEÇİLİ ALANDAKİ BUTONLARI DA KOPYALAR/YAPIŞTIRIR
    .PasteSpecial xlPasteValuesAndNumberFormats
    .PasteSpecial xlPasteColumnWidths
    .Range("AS1").Select
Application.CutCopyMode = False

End With
ws.Protect
     
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name & " " & Format(Now, "dd-mm-yyyy h-mm-ss")
If Val(Application.Version) < 12 Then
    'Excel 2000-2003
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    'Excel 2007-2010
    FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Dest
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

Workbooks(TempFileName & FileExtStr).VBProject.VBComponents.Import strTempFile 'modülü içeri al

    On Error Resume Next
    For I = 1 To 3
        '3. BURASI GÖNDERİLECEK MAİL ADRESİDİR
        .SendMail Array("Ceryanci33@Gmail.com", "Ceryanci34@Gmail.com", "Ceryanci35@Gmail.com"), _
        "Günlük Faaliyet Raporu"
        If Err.Number = 0 Then Exit For
    Next I
    On Error GoTo 0
    .Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Kill strTempFile

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

[Ceryanci33]

hocam aynen dediğiniz şekilde olacak. Son yazdığınız kod çalışıyor fakat butona basınca asıl çalışma kitabı da açılıyor yenisiyle birlikte. Eski doyanın yerini değiştirdiğim zaman ise kopyalama butonuna basınca ekteki gibi hata alıyorum. Büyük ihtimalle mail atılan kişide aynı hatayı alacak.

[Ceryanci33]

Ekteki uyarıyı alıyorum hocam.

[Yken]

hocam aynen dediğiniz şekilde olacak. Son yazdığınız kod çalışıyor fakat butona basınca asıl çalışma kitabı da açılıyor yenisiyle birlikte. Eski doyanın yerini değiştirdiğim zaman ise kopyalama butonuna basınca ekteki gibi hata alıyorum. Büyük ihtimalle mail atılan kişide aynı hatayı alacak.

Eski kitabı açmaya çalışması buton içinde eski bağlantıyı gördüğünden dolayıdır. Şimdi eski bağlantılar da temizlendi.
Virüs uyarısı için ise yeni dosyayı sağ tıklayıp "engellemeyi kaldır" butonunu tıklayın.

Kod: Tümünü seç

Sub mail_gonder_Modulile()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook, ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim strTempFile As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long
Dim shp As Shape
Dim MacroLink As String
Dim SplitLink As Variant
Dim NewLink As String

Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

strTempFile = Environ$("temp") & "\" & "~tmpexport.bas"
wb.VBProject.VBComponents("Module2").Export strTempFile 'modülü dışarı al

Range("AS1:BI12").Select
Set Source = Nothing
On Error Resume Next
'1. BURASI SAYFA KORUMAYI KALDIR VE TEKRAR KOY
ws.Unprotect Password:="2023" 'ŞİFRE VARSA AYARLA
Set Source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
    MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
    Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
    Selection.Cells.Count = 1 Or _
    Selection.Areas.Count > 1 Then
    MsgBox " Bir hata oluştu:" & vbNewLine & vbNewLine & _
    "Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
    Exit Sub
End If
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
    .Range("AS1").Select
     ActiveWindow.Zoom = 55
     ActiveWindow.ScrollColumn = Selection.Column
    .Paste '2. BURASI SEÇİLİ ALANDAKİ BUTONLARI DA KOPYALAR/YAPIŞTIRIR
    .PasteSpecial xlPasteValuesAndNumberFormats
    .PasteSpecial xlPasteColumnWidths
    .Range("AS1").Select
Application.CutCopyMode = False

End With
ws.Protect
     
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name & " " & Format(Now, "dd-mm-yyyy h-mm-ss")
If Val(Application.Version) < 12 Then
    'Excel 2000-2003
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    'Excel 2007-2010
    FileExtStr = ".xlsm": FileFormatNum = 52
End If

Dest.VBProject.VBComponents.Import strTempFile 'modülü içeri al

With Dest
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

  For Each shp In ActiveWorkbook.Sheets(1).Shapes
  shp.Select
      MacroLink = shp.OnAction
      If MacroLink <> "" And InStr(MacroLink, "!") <> 0 Then
          SplitLink = Split(MacroLink, "!")
          NewLink = SplitLink(1)
            If Right(NewLink, 1) = "'" Then
              NewLink = Left(NewLink, Len(NewLink) - 1)
            End If
          shp.OnAction = "'" & TempFileName & FileExtStr & "'!" & NewLink
      End If
  Next shp
   
    .Save
    On Error Resume Next
    For I = 1 To 3
        '3. BURASI GÖNDERİLECEK MAİL ADRESİDİR
        .SendMail Array("Ceryanci33@Gmail.com", "Ceryanci34@Gmail.com", "Ceryanci35@Gmail.com"), _
        "Günlük Faaliyet Raporu"
        If Err.Number = 0 Then Exit For
    Next I
    On Error GoTo 0
    .Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Kill strTempFile

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
MsgBox "Mail gönderildi", vbInformation
End Sub

[Ceryanci33]

Hocam gerçekten çok tam olarak istediğim gibi olmuş, elinize sağlık.

[Ceryanci33]

Hocam merhaba, iş yerinden kurumsal posta adresi ile outlook kurulumu yapıp mail atınca Konu kımsına makrodaki "Günlük Faaliyet Raporu" yerine çince garip harfler yazıyor. Bunu nasıl düzeltebiliriz. Yazıyı değiştirince çince harflerde değişiyor. Hocam birde Dosya ismini mailin gönderildiği tarihten bir öncesinin tarihi + Günlük Faaliyet raporu şeklinde yapabilir miyiz. Mesala Bugün makroyu çalıştırdım mail attım diyelim, gönderilen dosyanın ismi 14.04.2023 Günlük Faaliyet Raporu şeklinde. Mail Konusu da yine Günlük Faaliyet Raporu olacak.

[Yken]

Dünkü tarihi elde etmek için "Now -1" yazmak yeterli:
TempFileName = wb.Name & " " & Format(Now -1, "dd-mm-yyyy h-mm-ss")

Çince karakterler için ilgili cihazın ve Outlook programının dil ayarlarına bakılabilir. Tam bilgim yok.

[Ceryanci33]

Hocam çok şey denedim ama bir türlü düzelmiyor. Programı outlook u açacak, kime kısmına mail adreslerini yazacak konuyu ben elimde düzeltip gönder dicem, bu şekilde yapabilir miyiz.