Posts by Lapot

Sub AttachMultiFiles()
Dim inv As String, invPDF As String
Dim inv2 As String, inv2PDF As String
Dim inv3 As String, inv3PDF As String
'S = Stored location
'FOR INVOICE 1
S = Worksheets("Sheet1").Range("B2").Value
MyFilePath = S
'PDF convert
inv = MyFilePath
invPDF = TempPDF(inv)
MakeWordPDFFile inv, invPDF
'FOR INVOICE 2
S = Worksheets("Sheet1").Range("B3").Value
MyFilePath2 = S
'PDF convert
inv2 = MyFilePath2
inv2PDF = TempPDF(inv2)
MakeWordPDFFile inv2, inv2PDF
'FOR INVOICE 3
S = Worksheets("Sheet1").Range("B4").Value
MyFilePath3 = S
'PDF convert
inv3 = MyFilePath3
inv3PDF = TempPDF(inv3)
MakeWordPDFFile inv3, inv3PDF
'Create e-mail item
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.BodyFormat = olFormatHTML
.HTMLBody = "Here is the file you asked for"
.Attachments.Add invPDF
.Attachments.Add inv2PDF
.Attachments.Add inv3PDF
.Display
End With
End Sub

Private Sub MultipleAttach_Click()
Dim R As Range, fnd As Range, fn As String, fnPDF As String
Dim Ref1 As Long
Dim StrSignature As String
Dim sPath As String
Dim EmailBody As String
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String


sPath = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Signature.htm"
If Dir(sPath) <> "" Then
StrSignature = GetSignature(sPath)
Else
StrSignature = ""
End If
On Error Resume Next


Set R = Worksheets("Multi").Range("E2", _
Worksheets("Multi").Range("E" & Rows.Count).End(xlUp))
For i = 1 To ListView2.ListItems.Count
  '  If ListView2.ListItems(i).Checked = True Then
  If ListView2.ListItems(i).Selected = True Then
SearchInv = ListView2.ListItems(i).SubItems(5)
With R
        .NumberFormat = "0"
        .Value = .Value
        Set fnd = .Find(SearchInv.Value, LookAt:=xlWhole)
End With
     If Not fnd Is Nothing Then
        Unload Me
        fn = fnd.Offset(, 1).Value
        fnPDF = TempPDF(fn)
        MakeWordPDFFile fn, fnPDF
    
Else: MsgBox "Number not found!"
End If


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Ref1 = SearchInv.Value
strBody = ""
End If
Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Payment Reminder for Invoice No : " & Ref1
.Body = "Dear Sir" _
& vbCrLf & "" _
& vbCrLf & "Our records is showing that we haven't received payment for our Invoice No:  " & Ref1 _
& vbCrLf & "" _
& vbCrLf & "I will be grateful if you arrange payment against this invoice " _
& vbCrLf & ""
.Attachments.Add fnPDF
.HTMLBody = strBody & .HTMLBody & StrSignature
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
UserForm1.Show
'ThisWorkbook.RefreshAll
End Sub

Private Sub EmailInvoice_Click()
Dim R As Range, fnd As Range, fn As String, fnPDF As String
Dim Ref1 As Long
Dim StrSignature As String
Dim sPath As String
Dim EmailBody As String
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
sPath = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Signature.htm"
If Dir(sPath) <> "" Then
StrSignature = GetSignature(sPath)
Else
StrSignature = ""
End If
On Error Resume Next
Set R = Worksheets("invoice").Range("B2", _
Worksheets("invoice").Range("B" & Rows.Count).End(xlUp))
With R
        .NumberFormat = "0"
        .Value = .Value
        Set fnd = .Find(TextBox5.Value, LookAt:=xlWhole)
End With
     If Not fnd Is Nothing Then
        Unload Me
        fn = fnd.Offset(, 3).Value
        fnPDF = TempPDF(fn)
        MakeWordPDFFile fn, fnPDF
    
Else: MsgBox "Number not found!"
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Ref1 = TextBox5.Value
strBody = ""
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Payment Reminder for Invoice No : " & Ref1
.Body = "Dear Sir" _
& vbCrLf & "" _
& vbCrLf & "Our records is showing that we haven't received payment for our Invoice No:  " & Ref1 _
& vbCrLf & "" _
& vbCrLf & "I will be grateful if you arrange payment against this invoice " _
& vbCrLf & ""
.Attachments.Add fnPDF
.HTMLBody = strBody & .HTMLBody & StrSignature
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
UserForm1.Show
'ThisWorkbook.RefreshAll
End Sub


Function GetSignature(fPath As String) As String
    Dim fso As Object
    Dim TSet As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
    GetSignature = TSet.ReadAll
    TSet.Close
End Function


Private Sub PDFConvertor_Click()
Dim R As Range, fnd As Range, fn As String, fnPDF As String
On Error Resume Next
Set R = Worksheets("invoice").Range("B2", _
Worksheets("invoice").Range("B" & Rows.Count).End(xlUp))
With R
.NumberFormat = "0"
        .Value = .Value
        Set fnd = .Find(TextBox5.Value, LookAt:=xlWhole)
End With
     If Not fnd Is Nothing Then
        Unload Me
        fn = fnd.Offset(, 3).Value
        fnPDF = TempPDF(fn)
        MakeWordPDFFile fn, fnPDF
        ThisWorkbook.FollowHyperlink fnPDF
Else: MsgBox "Number not found!"
End If
UserForm1.Show
'ThisWorkbook.RefreshAll
End Sub

Sub datesexcelvba()
Dim myApp As Outlook.Application, mymail As Outlook.MailItem
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim Ref1 As Long
Dim example As Range
Set example = Range("T:T,U:U,W:W,X:X")
Dim fnd As Range
Dim attachment As String
Dim x As Long
example.ClearContents
LastRow = Sheets("Rapor").Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To LastRow
attachement = Sheets("Rapor").Cells(x, 25).Value
Ref1 = Cells(x, 5).Value
mydate1 = Cells(x, 4).Value
mydate2 = mydate1
Cells(x, 20).Value = mydate2
datetoday1 = Date
datetoday2 = datetoday1
Cells(x, 21).Value = datetoday2
If mydate2 - datetoday2 < 3 Then
Set myApp = New Outlook.Application
Set mymail = myApp.CreateItem(olMailItem)
mymail.To = Cells(x, 22).Value
With mymail
.Subject = "Payment Reminder"
.Body = "Dear Sir" _
& vbCrLf & "" _
& vbCrLf & "Our records is showing that we havent recived payment for our Invoice No: " & Ref1 _
& vbCrLf & "" _
& vbCrLf & "I will be greatful if you arrange payment aginst this invoice" _
& vbCrLf & "" _
& vbCrLf & "Kind Regards" _
& vbCrLf & "John Smith" _
& vbCrLf & "" _
& vbCrLf & ""
.Attachments.Add attachement
.Display
'.Send
Cells(x, 23) = "Yes"
Cells(x, 23).Interior.ColorIndex = 3
Cells(x, 23).Font.ColorIndex = 2
Cells(x, 23).Font.Bold = True
Cells(x, 24).Value = mydate2 - datetoday2
End With
If mydate2 - datetoday2 >= 3 Then
Cells(x, 23) = "No"
Cells(x, 23).Interior.ColorIndex = 5
Cells(x, 23).Font.ColorIndex = 6
Cells(x, 23).Font.Bold = True
Cells(x, 24).Value = mydate2 - datetoday2
Set mymail = Nothing
End If
End If
Next
Set myApp = Nothing
Set mymail = Nothing
End Sub

Sub AttachActiveSheetPDF_03()
' Copy this code to the module of any Excel's workbook.
' Prepare report/invoice in MyReport.doc or MyReport.docx and store it on Desktop
' This macro exports the report document to PDF and attaches that PDF to Outlook's email
 
  Dim IsOutlCreated As Boolean, IsWordCreated As Boolean, IsDocOpen As Boolean
  Dim DesktopPath As String, DocFile As String, PdfFile As String, Title As String, s As String
  Dim OutlApp As Object, WordApp As Object
  Dim i As Long
  Dim char As Variant
  Const wdExportFormatPDF = 17
 
  ' --> Settings, change to suit
  Const WordDocument = "MyReport.doc"
  'Title = Range("A1") & " " & Date
  Title = "PU: " & Date
  ' <-- End ofsettings
 
  ' Check WordDocument presence on Desktop
  DesktopPath = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
  DocFile = DesktopPath & "\" & WordDocument
  s = Dir(DocFile & "*")
  If s = "" Then
    MsgBox "Word Report file not found:" & vbLf & DocFile, vbExclamation, "Exit"
    Exit Sub
  End If
  DocFile = DesktopPath & "\" & s
 
  ' Define PDF filename in TEMP folder
  PdfFile = WordDocument
  i = InStrRev(PdfFile, ".", , vbTextCompare)
  If i > Len(PdfFile) - 6 Then PdfFile = Left(PdfFile, i - 1)
  For Each char In Split("? "" / \ < > * | :")
    PdfFile = Replace(PdfFile, char, "_")
  Next
  PdfFile = Left(CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\" & PdfFile, 251) & ".pdf"
  'Debug.Print PdfFile
 
  ' Delete PDF file - for the case it was not deleted at debugging
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Open WordDocument if it was not open previously
  On Error Resume Next
  Set WordApp = GetObject(, "Word.Application")
  If Err Then
    Set WordApp = CreateObject("Word.Application")
    IsWordCreated = True
  End If
  Err.Clear
  WordApp.ScreenUpdating = False
  With WordApp.Documents(s): End With
  IsDocOpen = Err = 0
  On Error GoTo 0 'exit_
  If Not IsDocOpen Then
    WordApp.Documents.Open Filename:=DocFile, ReadOnly:=IsWordCreated
  End If
 
  ' Export activedocument as PDF to the temporary folder
  WordApp.Documents(s).ExportAsFixedFormat OutputFileName:=PdfFile, ExportFormat:=wdExportFormatPDF
 
  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsOutlCreated = True
  End If
  On Error GoTo 0
 
  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
   
    ' Prepare e-mail
    .Subject = Title
    '.To = "..." ' <-- Put email of the recipient here
    '.CC = "..." ' <-- Put email of 'copy to' recipient here
    .Body = "Hi," & vbLf & vbLf _
          & "The invoice is attached in PDF file" & vbLf & vbLf _
          & "Best Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
   
    ' Try to send
    On Error Resume Next
    '.Send ' or use
    .Display
   
    ' Return focus to Excel's window
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
   ' Else
      'MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
 
  End With
 
exit_:
 
  ' Delete the temporary PDF file
  If Len(Dir(PdfFile)) Then Kill PdfFile
 
  ' Close WordDocument if it was open via this macro
  If IsDocOpen Then
    WordApp.Documents(s).Close False
  Else
    WordApp.ScreenUpdating = True
  End If
 
  ' Close WordApp if it was open via this macro
  If IsWordCreated Then WordApp.Quit: Set WordApp = Nothing
 
  ' Try to quit Outlook if it was not previously open
  If IsOutlCreated Then OutlApp.Quit
 
  ' Release the memory of object variable
  ' Note: sometimes Outlook object can't be released from the memory
  Set OutlApp = Nothing
 
  If Err Then MsgBox Err.Description, vbCritical, "Error #" & Err.Number
 
End Sub