Posts by RichardW

Sub email()
Set objEmail = CreateObject("CDO.Message")
Set objConf = CreateObject("CDO.Configuration")
  
Set objFlds = objConf.Fields
With objFlds
  .Item("[URL]http://schemas.microsoft.com/cdo/configuration/sendusing[/URL]") = 2
  .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserver[/URL]") = "smpt.telkom.net"
  .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserverport[/URL]") = 25
  '.Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpauthenticate[/URL]") = cdoBasic
  .Update
End With
Set objEmail.Configuration = objConf
  
objEmail.From = "[EMAIL="[email protected]"][email protected][/EMAIL]"
objEmail.To = "[EMAIL="[email protected]"][email protected][/EMAIL]"
objEmail.Subject = "All done!"
objEmail.Textbody = "...here you go..."
'objEmail.Addattachment "C:\directory name of file\filename"
objEmail.Send


End Sub

Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Sub EmailResults()
    Dim iMsg As Object, iConf As Object, RecipientName As String
    Dim Flds As Variant


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set iConf = CreateObject("CDO.Configuration")
        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("[URL]http://schemas.microsoft.com/cdo/configuration/sendusing[/URL]") = 2
            .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserver[/URL]") = "mail.yourISP.com"
            .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserverport[/URL]") = 25
            .Update
        End With
    With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = Application.DefaultFilePath & "\"
            .Title = "Select the Folder with the PDF's to email."
            .Show
            If .SelectedItems.Count = 0 Then
                Exit Sub
            Else
                FilePath = .SelectedItems(1)
            End If
        End With
        Set iMsg = CreateObject("CDO.Message")
        With iMsg
            Set .Configuration = iConf
            .To = "Something"
            .From = "Someone"
            .Subject = "Something"
            .TextBody = "Something"
          'Attach a file
          FileName = A Variable Name
          .AddAttachment FilePath & "\" & FileName
          .Send
        End With
                Set iMsg = Nothing


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End If
ErrorHandler:
'MsgBox Err.Number & Err.Description
Select Case Err.Number
    Case -2147024894
        MsgBox "File " & FileName & " is not in this folder." & Chr(13) & Chr(13) _
                           & "Try again"
    Case -2147220978
        MsgBox "You must provide a ""From"" name in cell C2 and an Email address in cell D2 in the " & EmailPageName & " Worksheet."
    End Select
End Sub

Private Sub Turn_Auto_Yes_On()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
wnd = FindWindow("EXCLICKYES_WND", 0&)
Res = SendMessage(wnd, uClickYes, 1, 0)
End Sub
Private Sub Turn_Off_Auto_Yes()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
wnd = FindWindow("EXCLICKYES_WND", 0&)
Res = SendMessage(wnd, uClickYes, 0, 0)
End Sub
Public Sub StartClickYes()
Dim strComputer As String, objWMI As Object, proc As Object
strComputer = "."
Set objWMI = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set proc = objWMI.ExecQuery("Select * from Win32_Process Where Name = 'ClickYes.exe'")
If proc.Count = 0 Then
If Location = 1 Then
Call Shell("C:\Program Files\Express ClickYes\ClickYes.exe", 1)
ElseIf Location = 2 Then
Call Shell("C:\Program Files (x86)\Express ClickYes\ClickYes.exe", 1)
ElseIf Location = 3 Then
Call Shell(Range("ClickYes"), 1)
End If
End If
End Sub
Public Sub ClickYesExists(ByRef Continue As String)
Dim Installed As Boolean
Installed = False
If Dir$("C:\Program Files\Express ClickYes\ClickYes.exe") <> vbNullString Then
Installed = True
Location = 1
ElseIf Dir$("C:\Program Files (x86)\Express ClickYes\ClickYes.exe") <> vbNullString Then
Installed = True
Location = 2
ElseIf Dir$(Range("ClickYes")) <> vbNullString Then
Installed = True
Location = 3
Else
MsgBox "The ClickYes program does not appear to be installed at its normal location" & Chr$(13) & Chr$(13) & "You must install it to send email or specify where it is installed in the Email Settings on the Settings page."
Continue = "No"
End If
End Sub
Public Sub CloseClickYes()
Dim strTerminateThis As String
Dim objWMIcimv2 As Object
Dim objProcess As Object
Dim objList As Object
Dim intError As Long
strTerminateThis = "ClickYes.exe"
Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='" & strTerminateThis & "'")
If objList.Count = 0 Then
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Exit Sub
Else
For Each objProcess In objList
intError = objProcess.Terminate
If intError <> 0 Then
Exit Sub
End If
Next
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Exit Sub
End If
End Sub

Public Sub SendToWord()
    
Dim wdDoc As Word.Document, objDoc As Word.Document, wdApp As Word.Application
Dim VARPersonA As Excel.Range, VARPersonB As Excel.Range, VARPersonC As Excel.Range
Dim VARFruitA As Excel.Range, VARFruitB As Excel.Range, VARFruitC As Excel.Range
Dim VARTotalFruit As Excel.Range
Set wdApp = New Word.Application
'Assign the Word file path and name to variables
FilePath = ThisWorkbook.Path
FileName = "Fruit1.dotx"
Set objDoc = wdApp.Documents.Add(Template:=FilePath & "\" & FileName)
If objDoc Is Nothing Then
    MsgBox "Unable to find the Word file.", vbCritical, "File Not Found"
    wdApp.Quit
    Set appWrd = Nothing
    Exit Sub
End If
        
Set VARPersonA = Range("ARPersonA")
Set VARPersonB = Range("ARPersonB")
Set VARPersonC = Range("ARPersonC")
Set VARFruitA = Range("ARFruitA")
Set VARFruitB = Range("ARFruitB")
Set VARFruitC = Range("ARFruitC")
Set VARTotalFruit = Range("ARTotalFruit")


With objDoc.Bookmarks
    .Item("ARPersonA").Range.InsertAfter VARPersonA
    .Item("ARPersonB").Range.InsertAfter VARPersonB
    .Item("ARPersonC").Range.InsertAfter VARPersonC
    .Item("ARTotalFruit").Range.InsertAfter VARTotalFruit
    .Item("ARFruitA").Range.InsertAfter VARFruitA & "s" 'add the s to Apple
    .Item("ARFruitB").Range.InsertAfter VARFruitB & "s"
    .Item("ARFruitC").Range.InsertAfter VARFruitC & "s"
End With
wdApp.Selection.Goto What:=wdGoToBookmark, Name:="ARTableFruit"
ThisWorkbook.Sheets("Sheet1").Range("B3:D7").Copy
wdApp.Selection.Paste
wdApp.Selection.Tables(1).Rows.Alignment = wdAlignRowLeft
        
wdApp.Selection.Goto What:=wdGoToBookmark, Name:="ARChartFruit"
ThisWorkbook.Sheets("Sheet1").ChartObjects(1).Copy
wdApp.Selection.Paste
wdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    
'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
'Let the user know the procedure is now complete
Prompt = "Click OK to Review the Fruit Report Document in the Taskbar."
Title = "Procedure Completion"
MsgBox Prompt, vbOKOnly + vbInformation, Title
'Make our Word session visible
wdApp.Visible = True
wdApp.ActiveDocument.SaveAs FilePath & "\" & " Fruit Report.docx"
'Clean up
Set wdApp = Nothing
Set objDoc = Nothing
       
End Sub

Sub DeliveryCost()
Dim i As Long,  CostofItems As Double, InsuranceCost As Double
'Delivery cost
CostofItems = Range("D12") / TextBox10
TextBox3 = Range("B12") / TextBox10
TextBox5 = CostofItems
For i = 1 To 30
    If WorksheetFunction.RoundUp(TextBox3.Value, 0) = Cells(i + 17, 2) Then
        TextBox4 = Cells(i + 17, 3)
        Exit For
    End If
Next i
For i = 18 To 21
    If CostofItems >= Cells(i, 9) And CostofItems <= Cells(i, 11) Then
        TextBox6 = Cells(i, 12)
        Exit For
    End If
Next i


If TextBox7 = vbNullString Then
    TextBox7 = "0"
End If
TextBox8 = ((CDbl(TextBox4) + CDbl(TextBox6)) * CDbl(TextBox10)) + CDbl(TextBox7)
TextBox8 = Format(CDbl(TextBox8) * CDbl((1 + Range("M18").Value)), "#,##0.00")
End Sub