home *** CD-ROM | disk | FTP | other *** search
/ Mastering Visual Basic 6 / mastvb6.iso / ch_code / ch14 / automssg / mssgform.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1996-05-27  |  8.3 KB  |  265 lines
  1. VERSION 5.00
  2. Begin VB.Form AutoMessageForm 
  3.    Caption         =   "VBA DEMO: E-Message Automation"
  4.    ClientHeight    =   6405
  5.    ClientLeft      =   60
  6.    ClientTop       =   375
  7.    ClientWidth     =   11850
  8.    LinkTopic       =   "Form1"
  9.    ScaleHeight     =   6405
  10.    ScaleWidth      =   11850
  11.    StartUpPosition =   3  'Windows Default
  12.    Begin VB.CommandButton Command3 
  13.       Caption         =   "Create && Send"
  14.       BeginProperty Font 
  15.          Name            =   "Verdana"
  16.          Size            =   9.75
  17.          Charset         =   0
  18.          Weight          =   400
  19.          Underline       =   0   'False
  20.          Italic          =   0   'False
  21.          Strikethrough   =   0   'False
  22.       EndProperty
  23.       Height          =   480
  24.       Left            =   9390
  25.       TabIndex        =   6
  26.       Top             =   5865
  27.       Width           =   2355
  28.    End
  29.    Begin VB.TextBox Text1 
  30.       BeginProperty Font 
  31.          Name            =   "Verdana"
  32.          Size            =   9
  33.          Charset         =   0
  34.          Weight          =   400
  35.          Underline       =   0   'False
  36.          Italic          =   0   'False
  37.          Strikethrough   =   0   'False
  38.       EndProperty
  39.       Height          =   5265
  40.       Left            =   5580
  41.       MultiLine       =   -1  'True
  42.       ScrollBars      =   2  'Vertical
  43.       TabIndex        =   5
  44.       Text            =   "MssgForm.frx":0000
  45.       Top             =   435
  46.       Width           =   6165
  47.    End
  48.    Begin VB.ListBox List3 
  49.       BeginProperty Font 
  50.          Name            =   "Verdana"
  51.          Size            =   9
  52.          Charset         =   0
  53.          Weight          =   400
  54.          Underline       =   0   'False
  55.          Italic          =   0   'False
  56.          Strikethrough   =   0   'False
  57.       EndProperty
  58.       Height          =   2370
  59.       Left            =   120
  60.       Sorted          =   -1  'True
  61.       TabIndex        =   4
  62.       Top             =   3330
  63.       Width           =   5340
  64.    End
  65.    Begin VB.ListBox List2 
  66.       BeginProperty Font 
  67.          Name            =   "Verdana"
  68.          Size            =   9
  69.          Charset         =   0
  70.          Weight          =   400
  71.          Underline       =   0   'False
  72.          Italic          =   0   'False
  73.          Strikethrough   =   0   'False
  74.       EndProperty
  75.       Height          =   2370
  76.       Left            =   2850
  77.       Sorted          =   -1  'True
  78.       TabIndex        =   1
  79.       Top             =   435
  80.       Width           =   2610
  81.    End
  82.    Begin VB.ListBox List1 
  83.       BeginProperty Font 
  84.          Name            =   "Verdana"
  85.          Size            =   9
  86.          Charset         =   0
  87.          Weight          =   400
  88.          Underline       =   0   'False
  89.          Italic          =   0   'False
  90.          Strikethrough   =   0   'False
  91.       EndProperty
  92.       Height          =   2370
  93.       Left            =   135
  94.       TabIndex        =   0
  95.       Top             =   435
  96.       Width           =   2580
  97.    End
  98.    Begin VB.Label Label3 
  99.       Caption         =   "Recipients"
  100.       BeginProperty Font 
  101.          Name            =   "Verdana"
  102.          Size            =   9.75
  103.          Charset         =   0
  104.          Weight          =   700
  105.          Underline       =   0   'False
  106.          Italic          =   0   'False
  107.          Strikethrough   =   0   'False
  108.       EndProperty
  109.       Height          =   285
  110.       Left            =   150
  111.       TabIndex        =   8
  112.       Top             =   3030
  113.       Width           =   2580
  114.    End
  115.    Begin VB.Label Label2 
  116.       Alignment       =   2  'Center
  117.       Caption         =   "Message Text"
  118.       BeginProperty Font 
  119.          Name            =   "Verdana"
  120.          Size            =   9.75
  121.          Charset         =   0
  122.          Weight          =   700
  123.          Underline       =   0   'False
  124.          Italic          =   0   'False
  125.          Strikethrough   =   0   'False
  126.       EndProperty
  127.       Height          =   285
  128.       Left            =   5610
  129.       TabIndex        =   7
  130.       Top             =   135
  131.       Width           =   6105
  132.    End
  133.    Begin VB.Label Label5 
  134.       Caption         =   "Contacts"
  135.       BeginProperty Font 
  136.          Name            =   "Verdana"
  137.          Size            =   9.75
  138.          Charset         =   0
  139.          Weight          =   700
  140.          Underline       =   0   'False
  141.          Italic          =   0   'False
  142.          Strikethrough   =   0   'False
  143.       EndProperty
  144.       Height          =   285
  145.       Left            =   2820
  146.       TabIndex        =   3
  147.       Top             =   135
  148.       Width           =   2670
  149.    End
  150.    Begin VB.Label Label1 
  151.       Caption         =   "Companies"
  152.       BeginProperty Font 
  153.          Name            =   "Verdana"
  154.          Size            =   9.75
  155.          Charset         =   0
  156.          Weight          =   700
  157.          Underline       =   0   'False
  158.          Italic          =   0   'False
  159.          Strikethrough   =   0   'False
  160.       EndProperty
  161.       Height          =   285
  162.       Left            =   135
  163.       TabIndex        =   2
  164.       Top             =   90
  165.       Width           =   2580
  166.    End
  167. Attribute VB_Name = "AutoMessageForm"
  168. Attribute VB_GlobalNameSpace = False
  169. Attribute VB_Creatable = False
  170. Attribute VB_PredeclaredId = True
  171. Attribute VB_Exposed = False
  172. '  ******************************
  173. '  ******************************
  174. '  ** MASTERING VB6            **
  175. '  ** by Evangelos Petroutos   **
  176. '  ** SYBEX, 1998              **
  177. '  ******************************
  178. '  ******************************
  179. Dim OLApp As Application
  180. Dim mNameSpace As NameSpace
  181. Dim mFolder As MAPIFolder
  182. Dim mItem As MailItem
  183. Dim mContact As ContactItem
  184. Dim allContacts As Items
  185. Sub StartOutlook()
  186. On Error GoTo OutlookNotStarted
  187.     Set OLApp = CreateObject("Outlook.Application")
  188. On Error GoTo NoMAPINameSpace
  189.     Set mNameSpace = OLApp.GetNamespace("MAPI")
  190.     List1.Clear
  191.     List2.Clear
  192.     Exit Sub
  193. OutlookNotStarted:
  194.     MsgBox "Could not start Outlook"
  195.     Exit Sub
  196. NoMAPINameSpace:
  197.     MsgBox "Could not get MAPI NameSpace"
  198.     Exit Sub
  199. End Sub
  200. Sub ReadContacts()
  201.     Set allContacts = mNameSpace.GetDefaultFolder(olFolderContacts).Items
  202.     allContacts.Sort "CompanyName"
  203. On Error Resume Next
  204.     For Each mContact In allContacts
  205.         If Trim(mContact.CompanyName) <> "" Then List1.AddItem mContact.CompanyName
  206.         If List1.List(List1.NewIndex) = List1.List(List1.NewIndex - 1) Then List1.RemoveItem List1.NewIndex
  207.     Next
  208. End Sub
  209. Private Sub Command3_Click()
  210. Dim thisMessage As MailItem
  211. Dim strMsg As String
  212.     strMsg = Text1.Text
  213.     For i = 0 To List3.ListCount - 1
  214.         Set thisMessage = OLApp.CreateItem(olMailItem)
  215.         With thisMessage
  216.             strMsg = Replace(strMsg, "<<NAME>>", List3.List(i))
  217.             .Recipients.Add List3.List(i)
  218.             .Subject = "News from Sybex " & Format(Date, vbLongDate)
  219.             .Body = strMsg
  220.             .Send
  221.         End With
  222.     Next
  223. End Sub
  224. Private Sub Form_Load()
  225.     StartOutlook
  226.     ReadContacts
  227. End Sub
  228. Private Sub List1_Click()
  229. Dim CompanyName As String
  230. Dim filterString As String
  231. Dim thisContact As ContactItem
  232.     If List1.ListIndex = -1 Then Exit Sub
  233.     CompanyName = List1.Text
  234.     filterString = "[CompanyName] = """ & CompanyName & """"
  235.         
  236.     Set thisContact = allContacts.Find(filterString)
  237.     If IsNull(thisContact) Then
  238.         MsgBox "Fatal error in locating a contact. Program will exit"
  239.         End
  240.     End If
  241.     List2.Clear
  242.     While Not thisContact Is Nothing
  243.         If Trim(thisContact.FullName) <> "" Then List2.AddItem thisContact.FullName
  244.         Set thisContact = allContacts.FindNext
  245.     Wend
  246. End Sub
  247. Private Sub List2_Click()
  248. Dim ContactName As String
  249. Dim filterString As String
  250.     If List2.ListIndex = -1 Then Exit Sub
  251.     ContactName = List2.Text
  252.     filterString = "[FullName] = """ & ContactName & """"
  253.         
  254.     Set thisContact = allContacts.Find(filterString)
  255.     If IsNull(thisContact) Then
  256.         MsgBox "Fatal error in locating a contact's name. Program will exit"
  257.         End
  258.     End If
  259. End Sub
  260. Private Sub List2_DblClick()
  261.     If List2.ListIndex >= 0 Then
  262.         List3.AddItem List2.Text
  263.     End If
  264. End Sub
  265.