Sent e-mail message by the OutLook Object

'UserForm1

'A) VBProject References List

'A1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'A2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'A3) Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\STDOLE2.TLB
'A5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL

'B) Addition Tools on UserForm1

'B1)Image1, Label1, Label2
'B2)CommandButton1
'B3)Label3, TextBox1
'B4)Label4, TextBox2
'B5)Label5, TextBox3
'B6)Label6, TextBox4
'B7)CommandButton2, ListBox1, CommandButton3
'B8)TextBox5

Option Explicit
Private i As Single
Private OutApp As Object
Private OutMail As Object
Private gFile As Variant
Private No As Double
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Sent e-mail message by the OutLook Object"
Call Ekran_Düzenle

End Sub
Private Sub CommandButton1_Click() 'Sent message

On Error Resume Next
If TextBox1.Text = "" Then

MsgBox "Please fill the blank areas!", vbInformation, "[PBİD®]"

Else

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail

.To = TextBox1.Value
.CC = TextBox2.Value
.BCC = TextBox3.Value
.Subject = TextBox4.Value
.Body = TextBox5.Value
If ListBox1.ListCount > 0 Then

For i = 0 To (ListBox1.ListCount - 1)

.Attachments.Add ListBox1.List(i, 0)

Next i

End If
.Send

End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End If

End Sub
Private Sub CommandButton2_Click() 'Add attachment

On Error Resume Next
gFile = Application.GetOpenFilename("Text Files (*.*), *.*", , "Please Select Attachment File", , True)
If VBA.IsArray(gFile) <> False Then ListBox1.AddItem gFile(1)

End Sub
Private Sub CommandButton3_Click() 'Delete attachment

On Error Resume Next
No = ListBox1.ListIndex
If No > -1 Then

ListBox1.RemoveItem No

Else

MsgBox "Please select an item!", vbInformation, "[PBİD®]"

End If

End Sub
Private Sub Ekran_Düzenle()

On Error Resume Next
With Me

.Width = 376
.Height = 306
.BackColor = vbWhite
.Picture = Resim(URL1)
'.Picture = LoadPicture("c:\...\*.jpg")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Image1

.Left = 6
.Top = 6
.Height = 24
.Width = 24
.BackColor = vbWhite
.BorderColor = vbBlue
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleSingle
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False

End With
With Label1

.Caption = "Mustafa ULUSARAÇ"
.Left = 36
.Top = 6
.Height = 16
.Width = 270
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.ForeColor = vbBlue
.Font.Bold = True
.SpecialEffect = fmSpecialEffectFlat

End With
With CommandButton1

.Caption = "Sent"
.Left = 318
.Top = 6
.Height = 24
.Width = 48
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.Font.Bold = True

End With
With Label2

.Caption = "01ulusarac@superonline.com"
.Left = 36
.Top = 18
.Height = 16
.Width = 270
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.ForeColor = vbBlue
.Font.Bold = True
.SpecialEffect = fmSpecialEffectFlat

End With
With Label3

.Caption = " To"
.Left = 6
.Top = 36
.Height = 15.75
.Width = 48
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.ForeColor = &H808000
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched

End With
With TextBox1

.Left = 60
.Top = 36
.Height = 15.75
.Width = 306
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleNone
.ForeColor = vbBlue
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched

End With
With Label4

.Caption = " Cc"
.Left = 6
.Top = 54
.Height = 15.75
.Width = 48
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.ForeColor = &H808000
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched

End With
With TextBox2

.Left = 60
.Top = 54
.Height = 15.75
.Width = 306
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleNone
.ForeColor = vbBlue
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched

End With
With Label5

.Caption = " BCc"
.Left = 6
.Top = 72
.Height = 15.75
.Width = 48
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.ForeColor = &H808000
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched

End With
With TextBox3

.Left = 60
.Top = 72
.Height = 15.75
.Width = 306
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleNone
.ForeColor = vbBlue
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched

End With
With Label6

.Caption = " Subject"
.Left = 6
.Top = 90
.Height = 15.75
.Width = 48
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.ForeColor = &H808000
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched

End With
With TextBox4

.Left = 60
.Top = 90
.Height = 15.75
.Width = 306
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleNone
.ForeColor = vbBlue
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched
.Value = VBA.Left(ActiveWorkbook.Name, VBA.Len(ActiveWorkbook.Name) - 4)

End With
With CommandButton2

.Caption = "+ Attach"
.Left = 6
.Top = 108
.Height = 24
.Width = 48
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.Font.Bold = True

End With
With ListBox1

.Left = 60
.Top = 108
.Height = 24
.Width = 252
.BackColor = &H80000013
.BorderStyle = fmBorderStyleNone
.ForeColor = vbBlue
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched
.AddItem ActiveWorkbook.FullName

End With
With TextBox5

.Left = 6
.Top = 138
.Height = 138.25
.Width = 360
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleNone
.ForeColor = vbBlue
.Font.Bold = False
.SpecialEffect = fmSpecialEffectEtched
.Value = "Hello; "
.MultiLine = True
.EnterKeyBehavior = True
.ScrollBars = fmScrollBarsVertical

End With
With CommandButton3

.Caption = "- Attach"
.Left = 318
.Top = 108
.Height = 24
.Width = 48
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
.Font.Bold = True

End With

End With

End Sub

'Module1

Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" 'It may take a few seconds, please wait.
Public Const URL1 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg" 'Microsoft Office Excel® Kod Klavuzu [Vector Backround]
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD Icon]
Public Const URL3 As String = "http://4.bp.blogspot.com/_hsHTxo_5L8E/TKHXL1-dHVI/AAAAAAAAClo/xxJAhuSHReI/s1600/seven-shine-1024-768.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD BackroundPicture]
Public URL As String
Sub Form_Aç() 'Open UserForm

On Error Resume Next
UserForm1.Show 0

End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...

On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim

End Function
'Sub References_List()

' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References

' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.fullpath
' No = No + 1

' Next Eleman

'End Sub