How to add this code to the userform ContactForm

J

josros60

Registered User.
Local time
Yesterday, 16:59
Joined
Mar 10, 2011
Messages
73
Hi I have this code from another excel file,

How can i add this code to the the userform "ContactForm" for the file Contact list for Invoicing-Demo2.xls which I am attaching it.

Here it's the code I would like to add the above so I can double click on the customer and send an email:

Code: 
Private Sub ListBox1_Click()
      Dim Customer  As Variant
      Dim Name As String
      Dim firstaddress As String
      Dim rng As Range
      
      Customer = Empty
      'If you add more than 500 names you will need to increase this
      With ActiveSheet.Range("a2:e1000")
            Name = ListBox1.Value
            Set Customer = .Find(What:=Name, LookIn:=xlValues)
            If Not Customer Is Nothing Then Customer.Rows.EntireRow.Select Else Exit Sub
      End With
       Set rng = Nothing
    On Error Resume Next
    ' Only send the visible cells in the selection.
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    ' You can also use a range with the following statement.
     Set rng = Sheets("Statement").Range("A3:I29").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
      
      
      'closes the form when you click on a name
     ' Unload Me
     Dim ce As Range, i As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strto As String, strcc As String, strbcc As String
    Dim strsub As String, StrBody As String
    Dim wksht As Worksheet
    Dim rw As Integer
    
       
            Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon
            Set OutMail = OutApp.CreateItem(0)
          
          Set wksht = Worksheets("ContactsCollection")
          rw = ActiveCell.Row
          
                strto = wksht.Cells(rw, "c").Value & ";" & wksht.Cells(rw, "J").Value
                strcc = "ar@hyperwallet.com" & ";" & "DLeung@hyperwallet.com" & ";" & wksht.Cells(rw, "K").Value
                strbcc = ""
                strsub = wksht.Cells(rw, "D").Value
                StrBody = "Hi" & " " & wksht.Cells(rw, "b").Value & "," & "<br>" & "<br>" & wksht.Cells(rw, "H").Value

                '"Account Delinquent"
                'wksht.Cells(rw, "D").Value
                
                'StrBody = "Hi" & " " & wksht.Cells(rw, "b").Value & ", " & vbCrLf & vbCrLf & "" & wksht.Cells(rw, "H").Value
                
                                
                                'End With
    
            With OutMail
                .To = strto
                .CC = strcc
                .BCC = strbcc
                .Subject = strsub
                .HTMLBody = StrBody & vbCrLf & RangetoHTML(rng) '.Body = StrBody
                .display
                
            End With
    
            Set OutMail = Nothing
            Set OutApp = Nothing
            Set Customer = Nothing
         
With UserForm1
Unload Me
End With
[a1].Select
End Sub

Thanks
 

Attachments

in form design, click on ANY button/control EXCEPT ListBox1
or forms_load event

get into the form code
ctl-end
paste the code

as long as you have a ListBox1 on the form , the code will attach itself.
so make sure you have the list box 1st.
 
Thank you for the reply.

I had to rename the listbox1 to ContactForm because i have listbox1 already.

here it's the code:

Code: 
Private Sub ContctForm_Click()
      Dim Customer  As Variant
      Dim Name As String
      Dim firstaddress As String
      Dim rng As Range
      
      Customer = Empty
      'If you add more than 500 names you will need to increase this
      With ActiveSheet.Range("a2:e1000")
            Name = ListBox1.Value
            Set Customer = .Find(What:=Name, LookIn:=xlValues)
            If Not Customer Is Nothing Then Customer.Rows.EntireRow.Select Else Exit Sub
      End With
       Set rng = Nothing
    On Error Resume Next
    ' Only send the visible cells in the selection.
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    ' You can also use a range with the following statement.
     Set rng = Sheets("Statement").Range("A3:I29").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
      
      
      'closes the form when you click on a name
     ' Unload Me
     Dim ce As Range, i As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strto As String, strcc As String, strbcc As String
    Dim strsub As String, StrBody As String
    Dim wksht As Worksheet
    Dim rw As Integer
    
       
            Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon
            Set OutMail = OutApp.CreateItem(0)
          
          Set wksht = Worksheets("ContactsCollection")
          rw = ActiveCell.Row
          
                strto = wksht.Cells(rw, "c").Value & ";" & wksht.Cells(rw, "J").Value
                strcc = "ar@hyperwallet.com" & ";" & "DLeung@hyperwallet.com" & ";" & wksht.Cells(rw, "K").Value
                strbcc = ""
                strsub = wksht.Cells(rw, "D").Value
                StrBody = "Hi" & " " & wksht.Cells(rw, "b").Value & "," & "<br>" & "<br>" & wksht.Cells(rw, "H").Value

                '"Account Delinquent"
                'wksht.Cells(rw, "D").Value
                
                'StrBody = "Hi" & " " & wksht.Cells(rw, "b").Value & ", " & vbCrLf & vbCrLf & "" & wksht.Cells(rw, "H").Value
                
                                
                                'End With
    
            With OutMail
                .To = strto
                .CC = strcc
                .BCC = strbcc
                .Subject = strsub
                .HTMLBody = StrBody & vbCrLf & RangetoHTML(rng) '.Body = StrBody
                .display
                
            End With
    
            Set OutMail = Nothing
            Set OutApp = Nothing
            Set Customer = Nothing
         
With UserForm1
Unload Me
End With
[a1].Select
End Sub

but now giving me the Run-time error "424" object require.

thanks again.
 
Can anybody help me please with this error?

Thank you.
 
Thanks for all your help.

I figure out the 424 error, now the problems is when i click any customer doesn' send email:

here it's the complete code: can any help me to get it work i send invoices every month and this will be very helpful, hope somebody help me, thanks.


Code: 
'For More : merkez-ihayat.blogspot.com
Dim Yeni_mi As Boolean
Dim lbl() As New Class1

Private Sub CommandButton1_Click()
Dim Son_Dolu_Satir, Bos_Satir As Long
If Me.TextBox1.Value = "" _
Or Me.TextBox2.Value = "" _
Or Me.TextBox3.Value = "" _
Or Me.TextBox5.Value = "" Then
Call MsgBox("The fields are not complete", vbInformation, "Edit Contact")
Exit Sub
End If
                        Son_Dolu_Satir = Sheets("ContactsInvoicing").Range("A65536").End(xlUp).Row
                
                        Bos_Satir = Son_Dolu_Satir + 1
                
                        Sheets("ContactsInvoicing").Range("A" & Bos_Satir).Value = _
                        Application.WorksheetFunction.Max(Sheets("ContactsInvoicing").Range("A:A")) + 1
                        Sheets("ContactsInvoicing").Range("B" & Bos_Satir).Value = TextBox1.Text
                
                        Sheets("ContactsInvoicing").Range("C" & Bos_Satir).Value = TextBox2.Text
                
                        Sheets("ContactsInvoicing").Range("D" & Bos_Satir).Value = TextBox3.Text
                        
                        Sheets("ContactsInvoicing").Range("E" & Bos_Satir).Value = ComboBox1.Value
                        
                        Sheets("ContactsInvoicing").Range("F" & Bos_Satir).Value = TextBox5.Text
                        
                        Sheets("ContactsInvoicing").Range("G" & Bos_Satir).Value = TextBox6.Text
                        
                        Sheets("ContactsInvoicing").Range("H" & Bos_Satir).Value = TextBox7.Text
                        
                        Sheets("ContactsInvoicing").Range("I" & Bos_Satir).Value = TextBox8.Text
                        
                        Sheets("ContactsInvoicing").Range("J" & Bos_Satir).Value = TextBox9.Text
                        
                        Sheets("ContactsInvoicing").Range("K" & Bos_Satir).Value = TextBox10.Text
                        
                        Sheets("ContactsInvoicing").Range("L" & Bos_Satir).Value = TextBox11.Text
                        
                        Sheets("ContactsInvoicing").Range("M" & Bos_Satir).Value = TextBox12.Text
                         Sheets("ContactsInvoicing").Range("M" & Bos_Satir).HorizontalAlignment = xlRight
                
                        Sheets("ContactsInvoicing").Select
                                
                
               ContactForm.Clear
            refresh
            Label14.Caption = ContactForm.ListCount
        
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub CommandButton3_Click()
Dim Silinecek_Satir, i As Long
Dim cevap As String

If TextBox1 = "" Or TextBox2 = "" Then
Call MsgBox("Choose the contact to delete", vbInformation, "Delete Contact")
Exit Sub
End If
    If ContactForm.ListIndex >= 0 Then
cevap = MsgBox("The contact to be deleted." _
& vbCrLf & "Do you want to proceed?", vbYesNo, "Delete Approval")
           If cevap = vbYes Then
           Yeni_mi = True
           Silinecek_Satir = ContactForm.ListIndex + 2
           Sheets("ContactsInvoicing").Rows(Silinecek_Satir).Delete
      End If
      End If
    
    CommandButton8_Click
    For i = 2 To Range("a65536").End(3).Row
            Cells(i, 1).Value = i - 1
        Next i
        
    refresh
    Label14.Caption = ContactForm.ListCount
End Sub

Private Sub CommandButton4_Click()
CommandButton8_Click
TextBox1.SetFocus
End Sub

Private Sub CommandButton5_Click()
On Error Resume Next
Dim sons As Long
Sheets("Data2").Select
sons = Sheets("Data2").[a65536].End(3).Row + 1
Cells(sons, 1) = TextBox13.Value
TextBox13 = ""
refresh2

End Sub

Private Sub CommandButton6_Click()
On Error Resume Next
Dim say, Silinecek_Satir2 As Long
Dim ara As Range

 If ListBox2.ListIndex >= 0 Then
cevap = MsgBox("The contact to be deleted." _
& vbCrLf & "Do you want to proceed?", vbYesNo, "Delete Approval")
    
        If cevap = vbYes Then
            Yeni_mi = True
            Silinecek_Satir2 = ListBox2.ListIndex + 2
            Sheets("Data2").Rows(Silinecek_Satir2).Delete
        End If
        End If
    
TextBox13 = ""
ListBox2.Clear
refresh2
End Sub

Private Sub CommandButton7_Click()
TextBox13 = Empty
End Sub

Private Sub CommandButton8_Click()
Dim del As Control
For Each del In UserForm1.Controls
If TypeName(del) = "TextBox" Or TypeName(del) = "ComboBox" Then
del.Text = Empty
End If
Next del
ContactForm.Value = ""
ListBox2.Value = ""
End Sub

Private Sub CommandButton9_Click()
Dim Degistirilecek_Satir As Long
Dim sor As String
If TextBox1 = "" Or TextBox2 = "" Then
Call MsgBox("click the contact so it can be updated", vbInformation, "Edit Contact")
Exit Sub
End If

sor = MsgBox("Are your sure?", vbYesNo)
If sor = vbNo Then Exit Sub

 Degistirilecek_Satir = ContactForm.ListIndex + 2
                        
                        Sheets("ContactsInvoicing").Range("B" & Degistirilecek_Satir).Value = TextBox1.Text
                
                        Sheets("ContactsInvoicing").Range("C" & Degistirilecek_Satir).Value = TextBox2.Text
                
                        Sheets("ContactsInvoicing").Range("D" & Degistirilecek_Satir).Value = TextBox3.Text
                        
                        Sheets("ContactsInvoicing").Range("E" & Degistirilecek_Satir).Value = ComboBox1.Value
                        
                        Sheets("ContactsInvoicing").Range("F" & Degistirilecek_Satir).Value = TextBox5.Text
                        
                        Sheets("ContactsInvoicing").Range("G" & Degistirilecek_Satir).Value = TextBox6.Text
                        
                        Sheets("ContactsInvoicing").Range("H" & Degistirilecek_Satir).Value = TextBox7.Text
                        
                        Sheets("ContactsInvoicing").Range("I" & Degistirilecek_Satir).Value = TextBox8.Text
                        
                        Sheets("ContactsInvoicing").Range("J" & Degistirilecek_Satir).Value = TextBox9.Text
                        
                        Sheets("ContactsInvoicing").Range("K" & Degistirilecek_Satir).Value = TextBox10.Text
                        
                        Sheets("ContactsInvoicing").Range("L" & Degistirilecek_Satir).Value = TextBox11.Text
                        Sheets("ContactsInvoicing").Range("M" & Degistirilecek_Satir).Value = TextBox12.Text
                        Sheets("ContactsInvoicing").Range("M" & Degistirilecek_Satir).HorizontalAlignment = xlRight

                        Sheets("ContactsInvoicing").Select
Call MsgBox("The contact has been updated", vbInformation, "Edit Contact")
refresh
End Sub

Private Sub Label28_Click()

End Sub

Private Sub ContactForm_Click()
Dim Bulunan_Satir_No As Long
    
    Bulunan_Satir_No = ContactForm.ListIndex + 2
    
    TextBox1.Text = Sheets("ContactsInvoicing").Range("B" & Bulunan_Satir_No).Value
    
    TextBox2.Text = Sheets("ContactsInvoicing").Range("C" & Bulunan_Satir_No).Value
    
    TextBox3.Text = Sheets("ContactsInvoicing").Range("D" & Bulunan_Satir_No).Value
    
    ComboBox1.Value = Sheets("ContactsInvoicing").Range("E" & Bulunan_Satir_No).Value
    
    TextBox5.Text = Sheets("ContactsInvoicing").Range("F" & Bulunan_Satir_No).Value
    
    TextBox6.Text = Sheets("ContactsInvoicing").Range("G" & Bulunan_Satir_No).Value
    
    TextBox7.Text = Sheets("ContactsInvoicing").Range("H" & Bulunan_Satir_No).Value
    
    TextBox8.Text = Sheets("ContactsInvoicing").Range("I" & Bulunan_Satir_No).Value
    
    TextBox9.Text = Sheets("ContactsInvoicing").Range("J" & Bulunan_Satir_No).Value
    
    TextBox10.Text = Sheets("ContactsInvoicing").Range("K" & Bulunan_Satir_No).Value
    
    TextBox11.Text = Sheets("ContactsInvoicing").Range("L" & Bulunan_Satir_No).Value
    
    TextBox12.Text = Sheets("ContactsInvoicing").Range("M" & Bulunan_Satir_No).Value
    TextBox12.Text = VBA.Format(TextBox12, "dd.mm.yyyy")
    
    TextBox13.Text = Sheets("ContactsInvoicing").Range("N" & Bulunan_Satir_No).Value
    
    TextBox14.Text = Sheets("ContactsInvoicing").Range("O" & Bulunan_Satir_No).Value
    
    
    
End Sub


Private Sub UserForm_Click()

End Sub

Private Sub ListBox2_Click()
Dim No As Long
No = ListBox2.ListIndex + 2
TextBox13.Value = Sheets("Data2").Range("A" & No).Value
End Sub


Private Sub MultiPage2_Change()

End Sub

Private Sub TextBox13_Change()
On Error Resume Next
TextBox13 = Evaluate("=proper(""" & TextBox13 & """)")
End Sub
Private Sub SpinButton1_SpinDown()
On Error Resume Next
If ContactForm.ListIndex = ListBox1.ListCount - 1 Then Exit Sub
With Me.ContactForm
        .ListIndex = .ListIndex + 1
    End With
End Sub

Private Sub SpinButton1_SpinUp()
On Error Resume Next
If ContactForm.ListIndex = 0 Then Exit Sub
With Me.ContactForm
        .ListIndex = .ListIndex - 1
    End With
    End Sub
Sub refresh()
Dim sds As Long
ContactForm.ColumnCount = 2
ContactForm.ColumnWidths = "74;78"
sds = Sheets("ContactsInvoicing").[a65536].End(xlUp).Row
ContactForm.List = Sheets("ContactsInvoicing").Range("B2:C" & sds).Value
End Sub
Sub refresh2()
Dim sds2 As Long
sds2 = Sheets("Data2").[a65536].End(xlUp).Row
ListBox2.List = Sheets("Data2").Range("A2:A" & sds2).Value
End Sub

Private Sub ToggleButton1_Click()
If ToggleButton1.Value = False Then
    Application.Visible = False
    ToggleButton1.BackColor = &H80FF&
   End If
   If ToggleButton1.Value = True Then
    Application.Visible = True
    ToggleButton1.BackColor = &H80FF&
End If
End Sub
Private Sub Label19_Click()
Workbooks.Add
End Sub
Private Sub Label20_Click()
Application.Dialogs(xlDialogOpen).Show
End Sub

Private Sub Label21_Click()
ActiveWorkbook.Save
End Sub

Private Sub Label22_Click()
Application.Dialogs(xlDialogSaveAs).Show
End Sub

Private Sub Label23_Click()
UserForm1.Hide
ActiveSheet.PrintPreview
UserForm1.Show
End Sub

Private Sub Label24_Click()
ActiveSheet.PrintOut
End Sub

Private Sub Label25_Click()
UserForm1.Hide
End Sub
Private Sub Label18_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)

Label18.Font.Bold = True
Label18.Font.Size = 11
Frame2.Visible = True
End Sub

Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Frame2.Visible = False
Label18.SpecialEffect = fmSpecialEffectFlat
End Sub
Private Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Dim a As Integer
For a = 19 To 25
Controls("label" & a).BackColor = &H8000000F
Controls("label" & a).ForeColor = &H80000006
Next
End Sub

Private Sub TextBox3_Change()

End Sub

Private Sub UserForm_Initialize()
Dim x, sds, sds2, say1 As Long
       
say1 = WorksheetFunction.CountA(Worksheets("Data2").Range("a:a"))
ComboBox1.RowSource = "Data2!a2:a" & say1
ContactForm.ColumnCount = 2
ContactForm.ColumnWidths = "74;78"
   
sds = Sheets("ContactsInvoicing").[a65536].End(xlUp).Row
ContactForm.List = Sheets("ContactsInvoicing").Range("B2:C" & sds).Value
      
sds2 = Sheets("Data2").[a65536].End(xlUp).Row
ListBox2.List = Sheets("Data2").Range("A2:A" & sds2).Value
 
Label14.Caption = ContactForm.ListCount
ContactForm.ListIndex = 0

Frame2.Visible = False
ReDim Preserve lbl(6)
For a = 19 To 25
Set lbl(a - 19).lbl = Controls("label" & a)
Next
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Frame2.Visible = False
Label18.Font.Bold = False
End Sub

Private Sub ContctForm_Click()
      Dim Customer  As Variant
      Dim Name As String
      Dim firstaddress As String
      Dim rng As Range
      
      Customer = Empty
      'If you add more than 500 names you will need to increase this
      With ActiveSheet.Range("a2:e1000")
            Name = ContactForm.Value
            Set Customer = .Find(What:=Name, LookIn:=xlValues)
            If Not Customer Is Nothing Then Customer.Rows.EntireRow.Select Else Exit Sub
      End With
       Set rng = Nothing
    On Error Resume Next
    ' Only send the visible cells in the selection.
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    ' You can also use a range with the following statement.
     Set rng = Sheets("Statement").Range("A3:I29").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
      
      
      'closes the form when you click on a name
     ' Unload Me
     Dim ce As Range, i As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strto As String, strcc As String, strbcc As String
    Dim strsub As String, StrBody As String
    Dim wksht As Worksheet
    Dim rw As Integer
    
       
            Set OutApp = CreateObject("Outlook.Application")
            OutApp.Session.Logon
            Set OutMail = OutApp.CreateItem(0)
          
          Set wksht = Worksheets("ContactsCollection")
          rw = ActiveCell.Row
          
                strto = wksht.Cells(rw, "c").Value & ";" & wksht.Cells(rw, "J").Value
                strcc = "ar@hyperwallet.com" & ";" & "DLeung@hyperwallet.com" & ";" & wksht.Cells(rw, "K").Value
                strbcc = ""
                strsub = wksht.Cells(rw, "D").Value
                StrBody = "Hi" & " " & wksht.Cells(rw, "b").Value & "," & "<br>" & "<br>" & wksht.Cells(rw, "H").Value

                '"Account Delinquent"
                'wksht.Cells(rw, "D").Value
                
                'StrBody = "Hi" & " " & wksht.Cells(rw, "b").Value & ", " & vbCrLf & vbCrLf & "" & wksht.Cells(rw, "H").Value
                
                                
                                'End With
    
            With OutMail
                .To = strto
                .CC = strcc
                .BCC = strbcc
                .Subject = strsub
                .HTMLBody = StrBody & vbCrLf & RangetoHTML(rng) '.Body = StrBody
                .display
                
            End With
    
            Set OutMail = Nothing
            Set OutApp = Nothing
            Set Customer = Nothing
         
With UserForm1
Unload Me
End With
[a1].Select
End Sub

I am attaching the file.
 

Attachments

You must log in or register to reply here.

Similar threads

E
SendKeys "%{S}" Not Working anymore?
Replies
7
Views
490
Gasman
Gasman
D
Default Signature new outlook current user
Replies
17
Views
781
GPGeorge
GPGeorge
K
How can I add this code to the storage location of my file before scanning and then convert it to a PDF file?
2
Replies
25
Views
1,292
The_Doc_Man
The_Doc_Man
A
Solved VBA code for deleting Outlook 'Appointments' lying within a specified date range
Replies
8
Views
542
Gasman
Gasman
Gasman
Solved Open Excel workbook, but have WorkBook_Open code run
Replies
19
Views
641
Gasman
Gasman

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom