DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Private Sub CommandButton1_Click()
'xxxxxxxxxxxxxxxxxxxxxxxxxx Mail Adres Birleştir xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Set S1 = Sheets(ActiveSheet.Name)
S1.Cells(2, 4).Value = ""
CommandButton3_Click
If S1.Cells(2, 4).Value = "" Then
MsgBox "mail adresi seçilmedi"
Exit Sub
End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
msg1 = MsgBox("Mail dosyası göndermek istiyormusunuz.? " & Chr(10) & Chr(10) & _
"Mail dosyası eklemek için EVET tıklayınız. " & Chr(10) & Chr(10) & _
"Dosya eklemeden göndermek için HAYIR tıklayınız. " & Chr(10) & Chr(10) & _
"İşlem yapmadan çıkmak için İPTAL tıklayınız. ", vbYesNoCancel + vbInformation, "u y a r ı !")
If msg1 = vbCancel Then
Exit Sub
End If
Dim Mail_Dosyası As String
If msg1 = vbYes Then
DsyTur = "Excel Files(*.xls;*.xlsx;*.xlsm), *.xls;*.xlsx;*.xlsm"
DsyTur = DsyTur & ",MSForm Resim Dosyaları (*.jpg;*.jpe;*.gif;*.jpeg;*.ico), *.jpg;*.jpe;*.gif;*.jpeg;*.ico"
DsyTur = DsyTur & ",Metin Belgeleri(*.txt), *.txt"
DsyTur = DsyTur & ",Visual Basic Files (*.txt; *.bas), *.txt; *.bas"
DsyTur = DsyTur & ",Tüm Dosyalar(*.*), *.*"
a = Application.GetOpenFilename(DsyTur)
If a = False Then
MsgBox "Kaynak klasörü seçmediniz"
Exit Sub
End If
End If
Mail_Dosyası = a
Dim bool As Boolean
On Error Resume Next
yer = Mid(CreateObject("wscript.Shell").SpecialFolders.Item(1), 1, 2) 'Cells(1, "k").Value
strRefPath = yer & "\Program Files\Microsoft Office\OFFICE12\msoutl.olb" 'ADO
bool = False
For Each ref In ThisWorkbook.VBProject.References
If ref.FullPath = strRefPath Then bool = True
Next
Dim Outlook_Uygulaması As Outlook.Application
Dim Yeni_Mail As Outlook.MailItem
If msg1 = vbYes Then
'Mail_Dosyası = ThisWorkbook.Path & "\liste.xls" ' Eklene dosya
If CreateObject("Scripting.FileSystemObject").FileExists(Mail_Dosyası) = False Then MsgBox (Mail_Dosyası & Chr(10) & "Eklenecek liste dosyası yok"): Exit Sub
End If
Set Outlook_Uygulaması = New Outlook.Application
Set Yeni_Mail = CreateItem(olMailItem)
With Yeni_Mail
adr = S1.Cells(2, 4).Value
.To = adr
satir1 = S1.Cells(2, "e").Value
.Subject = satir1
satir2 = S1.Cells(2, "H").Value
satir3 = S1.Cells(3, "H").Value
satir4 = S1.Cells(4, "H").Value
satir5 = S1.Cells(5, "H").Value
satir6 = S1.Cells(6, "H").Value
satir7 = S1.Cells(7, "H").Value
satir8 = S1.Cells(7, "H").Value
.Body = satir2 & Chr(13) & Chr(13) & _
satir3 & Chr(13) & Chr(13) & _
satir4 & Chr(13) & Chr(13) & _
satir5 & Chr(13) & Chr(13) & _
satir6 & Chr(13) & Chr(13) & _
satir7 & Chr(13) & Chr(13) & _
satir8 & Chr(13) & Chr(13)
If msg1 = vbYes Then
.Attachments.Add Mail_Dosyası
End If
'.Display ' Maili ekranda görüntüler.
.Send ' Maili direk gönderir.
End With
Set Outlook_Uygulaması = Nothing
Set Yeni_Mail = Nothing
MsgBox "Bu Mail ile " & adr & " adresine " & ShName & " sayfası gönderildi.", vbApplicationModal, "Bilgilendirme!"
End Sub
Private Sub CommandButton2_Click()
Set S1 = Sheets(ActiveSheet.Name)
Dim sonuc As String, C As Range
On Error GoTo Hata
Set ALAN = S1.Range("c2:c1684")
For Each C In ALAN
If C <> Empty Then sonuc = sonuc & C.Value & "; " & sALAN
Next C
sonuc = Left(sonuc, Len(sonuc) - Len(sALAN))
S1.Range("d2") = sonuc
On Error GoTo 0
Hata:
BİRLEŞTİRA = "#Error#"
End Sub
Private Sub CommandButton3_Click()
Set S1 = Sheets(ActiveSheet.Name)
For r = 2 To S1.Cells(Rows.Count, "a").End(3).Row 'kisi_sayisi + 1
If S1.Cells(r, "c").Value <> "" Then
If S1.Cells(r, "b").Value = True Then
sonuc = sonuc & S1.Cells(r, "c").Value & "; "
End If
End If
Next
S1.Cells(2, "d").Value = sonuc
End SubSub Nesneleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
Picture.Delete
End If
Next Picture
End Sub
Sub Nesneleriekle()
On Error Resume Next
Set S1 = Sheets(ActiveSheet.Name)
For r = 1 To S1.Shapes.Count
If TypeName(S1.Shapes(r).OLEFormat.Object) = "CheckBox" Then
a = MsgBox("Nesneler mevcut yeniden nesneleri oluşturmak istiyorsanız" & Chr(10) & Chr(10) & _
"Nesneleri sil seçeneğine tıkladıktan sonra yeniden deneyiniz.", vbInformation, " U Y A R I ")
Exit Sub
End If
Next
sut = "b"
For r = 2 To S1.Cells(Rows.Count, "a").End(3).Row 'kisi_sayisi + 1
S1.Rows(r).RowHeight = 18
S1.Cells(r, sut).Font.ColorIndex = 2
If S1.Cells(r, "a").Value <> "" Then
yer = S1.CheckBoxes.Add(1, 1, 1, 1).Name
'yer1 = Selection.ShapeRange.AlternativeText
S1.Shapes(yer).OLEFormat.Object.Top = S1.Cells(r, sut).Top + 4 ' + say
S1.Shapes(yer).OLEFormat.Object.Left = S1.Cells(r, sut).Left
S1.Shapes(yer).OLEFormat.Object.Height = S1.Cells(r, sut).Height - 8
S1.Shapes(yer).OLEFormat.Object.Width = S1.Cells(r, sut).Width - 4
S1.Shapes(yer).OLEFormat.Object.Characters.Text = Cells(r, "a").Value
S1.Shapes(yer).OLEFormat.Object.Value = xlOff
S1.Shapes(yer).OLEFormat.Object.LinkedCell = S1.Cells(r, sut).Address
S1.Cells(r, sut).Value = "" ' "YANLIŞ"
S1.Shapes(yer).OLEFormat.Object.Display3DShading = False
'say = say + 1
S1.Shapes(yer).OLEFormat.Object.Name = "Onay Kutusu " & r - 1
'MsgBox ActiveSheet.Shapes(SH.Name).OLEFormat.Object.Name
End If
Next r
'sh.Range("A1").Select
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
Sub hepsinisec()
'On Error Resume Next
Dim Picture As Object
Set S1 = Sheets(ActiveSheet.Name)
For Each Picture In S1.Shapes
If TypeName(S1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
'If Picture.BottomRightCell.Row >= 24 And Picture.BottomRightCell.Row <= 39 Then
'If Picture.BottomRightCell.Column = 22 Then
S1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn
'End If
'End If
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
Sub secimlerikaldır()
On Error Resume Next
Dim Picture As Object
Set S1 = Sheets(ActiveSheet.Name)
For Each Picture In S1.Shapes
If TypeName(S1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
S1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOff
End If
Next Picture
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
[FONT="Trebuchet MS"][SIZE="2"].display
SendKeys "[COLOR="red"]%G[/COLOR]", True[/SIZE][/FONT]
#If Win64 And VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hwnd As Long) As Long
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwnd As Long) As Long
#End If
Private Const BM_CLICK = &HF5
Sub test()
Set app = CreateObject("Outlook.Application")
Set msg = app.CreateItem(0)
msg.To = "adres"
msg.Subject = "konu"
msg.Body = "mesaj"
msg.Send
Do
DoEvents
[COLOR=DarkGreen] 'Pencereyi bulana kadar çalış[/COLOR]
hw = FindWindow(vbNullString, "Microsoft Office Outlook")
If hw <> 0 Then Exit Do
Loop
[COLOR=DarkGreen] 'Ekran güncellemesini kapat (Pencere ekranda görünmeyecek)[/COLOR]
Call LockWindowUpdate(hw)
[COLOR=DarkGreen]'Evet butonunu bul[/COLOR]
hwEvet = FindWindowEx(hw, 0&, "Button", "Evet")
[COLOR=DarkGreen] 'Butona bas[/COLOR]
Call SendMessage(hwEvet, BM_CLICK, 0, 0)
[COLOR=DarkGreen] 'Ekran güncellemesini aç[/COLOR]
Call LockWindowUpdate(0)
End SubCall SendMessage(hwEvet, BM_CLICK, 0, [COLOR="Red"]0[/COLOR])#If VBA7 Then
Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperationAs String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If
Sub mail_gönder()
Dim Outlook_Uygulaması As Object
Dim Outlook_Mail As Object
Set S1 = Sheets("mail listesi")
Set S2 = Sheets("ana sayfa")
Program_Yolu = "C:\Program Files\WinRAR\WinRAR.exe"
If Dir(Program_Yolu) = "" Then
MsgBox "Sisteminizde yüklü WinRAR sıkıştırma programını bulunamamıştır !" & vbCrLf & "Lütfen daha sonra tekrar deneyiniz !", vbCritical, "Dikkat !"
Exit Sub
End If
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
yer = Format(Now, "dd-mm-yyyy-hh-nn-ss") & " " & fL.GetBaseName(ThisWorkbook.Name)
Dosya_Adı = InputBox("Arşivlenecek dosya adını yazınız.", "Uyarı", yer)
If Dosya_Adı = "" Or Dosya_Adı = False Then
MsgBox "Hatalı dosya adı girdiniz yada işlemi iptal ettiniz !" & vbCrLf & "Lütfen daha sonra tekrar deneyiniz !", vbExclamation, "Dikkat !"
Exit Sub
End If
Dosya_Adı = Replace(Dosya_Adı, " ", "-")
Yol = ThisWorkbook.Path & "\" & Dosya_Adı
deg1 = Split(Yol, " ")
If UBound(deg1) > 0 Then
MsgBox Yol & Chr(10) & UBound(deg1) & " kerekter boşluk var" & Chr(10) & "ilgili klasör adında veya yolunda kelimeler arasında boşluklar var"
For i = 0 To UBound(Split(Yol, " "))
MsgBox deg1(i)
Next
MsgBox "Dosya yolunu değiştirin."
Exit Sub
End If
S2.Copy
'Sheets(ActiveSheet.Name).Name = "Sayfa1"
Sheets(ActiveSheet.Name).Cells.Copy
Sheets(ActiveSheet.Name).Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Yol & "." & fL.GetExtensionName(ThisWorkbook.Name)
ActiveWorkbook.Close False
ShellExecute 0, "Open", Program_Yolu, "A -ep " & Yol & " " & Yol & "." & fL.GetExtensionName(ThisWorkbook.Name), "", vbHide
Application.Wait Now + TimeValue("00:00:10")
Set Outlook_Uygulaması = CreateObject("Outlook.Application")
Outlook_Uygulaması.Session.Logon
Set Outlook_Mail = Outlook_Uygulaması.CreateItem(0)
With Outlook_Mail
.To = S1.Cells(1, "b").Value
.CC = S1.Cells(2, "b").Value
.BCC = S1.Cells(3, "b").Value
.Subject = "konu başlığı"
.Body = "merhaba"
.BodyFormat = 2
.Attachments.Add Yol & ".rar"
'.Display
.Send
End With
Set Outlook_Mail = Nothing
Set Outlook_Uygulaması = Nothing
fL.DeleteFile Yol & "." & fL.GetExtensionName(ThisWorkbook.Name) 'Dosya_Adı
fL.DeleteFile Yol & ".rar" ' rar adı
End Sub