Hello members,
Can someone help me about the following codes written on VBA 2003? It does not working on 2013. I think filesearch..etc is no more available.
Sub gonder()
Dim ek As Object
Dim objOlk As Object, evn As Object, strresmim As String
Dim objEkle As Object, objevn As Object, evngovde As String
Rem Www.ExcelVBA.Net - 29.06.2010 - Tarkan VURAL
strresmim = "C:\Documents and Settings\ksy05\Desktop\svkyt\svk rpr2.jpg"
Sheets("form").Unprotect Password:="0000"
Sheets("form").[a1:aa20].CurrentRegion.CopyPicture xlScreen, xlBitmap
Set ek = ActiveSheet.ChartObjects.Add(, , 2000, 700).Chart
ek.Paste
ek.Export strresmim
ek.Parent.Delete
Set objOlk = CreateObject("Outlook.Application")
Set evn = objOlk.CreateItem(0)
evn.To = Sheets("mail").[a3].Value
evn.CC = [h2].Value
evn.BCC = [h3].Value
evn.Subject = [h4].Value
evngovde = Sheets("form").[A1].Value & "<br>" & Sheets("form").[aa20].Value
Set objEkle = evn.Attachments
Set objevn = objEkle.Add(strresmim)
evn.Close olSave
evn.HTMLBody = evngovde & "<br><IMG alt='' hspace=0 src='cid:'" & _
strresmim & "'' align=baseline border=0><br></BODY>"
evn.Save
evn.Display
evn.Send
strresmim = vbNullString
Sheets("form").Protect Password:="0000"
Set evn = Nothing: Set objOlk = Nothing
Set objevn = Nothing: Set objEkle = Nothing
evngovde = vbNullString: Set ek = Nothing
End Sub
Dim rng As Range
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
.HTMLBody = RangetoHTML(rng) & imza
'.Signature = imza
With Application.FileSearch
.LookIn = sPDFPath 'arama yapılan dizin
.SearchSubFolders = False 'alt klasörler aransın mı
'.FileType = msoFileTypeExcelWorkbooks aranacak dosya türleri
.Filename = "*.pdf" 'aranacak dosya isimleri/uzantıları
If .Execute() > 0 Then
'MsgBox .FoundFiles.Count & " adet dosya bulundu."
For i = 1 To .FoundFiles.Count
OutMail.Attachments.Add .FoundFiles(i)
Next i
Else
MsgBox "Hiç dosya bulunamadı.", vbCritical
End If
End With
.Display
'.Text = "Konu kisminda belirtilen dokumanlarin dagitimi ilgili bolumlere yapilmistir.OK/Onay maili donulmesi."
End With
Set OutMail = Nothing
Set OutApp = Nothing
Sheets("sevkler").Protect Password:="0000"
ThisWorkbook.Save
' SendKeys "^v"
End Sub
Thanks in advance!
Can someone help me about the following codes written on VBA 2003? It does not working on 2013. I think filesearch..etc is no more available.
Sub gonder()
Dim ek As Object
Dim objOlk As Object, evn As Object, strresmim As String
Dim objEkle As Object, objevn As Object, evngovde As String
Rem Www.ExcelVBA.Net - 29.06.2010 - Tarkan VURAL
strresmim = "C:\Documents and Settings\ksy05\Desktop\svkyt\svk rpr2.jpg"
Sheets("form").Unprotect Password:="0000"
Sheets("form").[a1:aa20].CurrentRegion.CopyPicture xlScreen, xlBitmap
Set ek = ActiveSheet.ChartObjects.Add(, , 2000, 700).Chart
ek.Paste
ek.Export strresmim
ek.Parent.Delete
Set objOlk = CreateObject("Outlook.Application")
Set evn = objOlk.CreateItem(0)
evn.To = Sheets("mail").[a3].Value
evn.CC = [h2].Value
evn.BCC = [h3].Value
evn.Subject = [h4].Value
evngovde = Sheets("form").[A1].Value & "<br>" & Sheets("form").[aa20].Value
Set objEkle = evn.Attachments
Set objevn = objEkle.Add(strresmim)
evn.Close olSave
evn.HTMLBody = evngovde & "<br><IMG alt='' hspace=0 src='cid:'" & _
strresmim & "'' align=baseline border=0><br></BODY>"
evn.Save
evn.Display
evn.Send
strresmim = vbNullString
Sheets("form").Protect Password:="0000"
Set evn = Nothing: Set objOlk = Nothing
Set objevn = Nothing: Set objEkle = Nothing
evngovde = vbNullString: Set ek = Nothing
End Sub
Dim rng As Range
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
.HTMLBody = RangetoHTML(rng) & imza
'.Signature = imza
With Application.FileSearch
.LookIn = sPDFPath 'arama yapılan dizin
.SearchSubFolders = False 'alt klasörler aransın mı
'.FileType = msoFileTypeExcelWorkbooks aranacak dosya türleri
.Filename = "*.pdf" 'aranacak dosya isimleri/uzantıları
If .Execute() > 0 Then
'MsgBox .FoundFiles.Count & " adet dosya bulundu."
For i = 1 To .FoundFiles.Count
OutMail.Attachments.Add .FoundFiles(i)
Next i
Else
MsgBox "Hiç dosya bulunamadı.", vbCritical
End If
End With
.Display
'.Text = "Konu kisminda belirtilen dokumanlarin dagitimi ilgili bolumlere yapilmistir.OK/Onay maili donulmesi."
End With
Set OutMail = Nothing
Set OutApp = Nothing
Sheets("sevkler").Protect Password:="0000"
ThisWorkbook.Save
' SendKeys "^v"
End Sub
Thanks in advance!