Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function ShellExecute Lib "shell32.dll" _
   Alias "ShellExecuteA" _
  (ByVal hwnd As Long, _
   ByVal lpOperation As String, _
   ByVal lpFile As String, _
   ByVal lpParameters As String, _
   ByVal lpDirectory As String, _
   ByVal nShowCmd As Long) As Long
    
Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWDEFAULT As Long = 10

Private Type EmailInfo
   sAddrTo As String
   sAddrCC As String
   sAddrBCC As String
   sAddrFrom As String
   sSubject As String
   sMessage As String
   sPriority As Long
End Type
   


Private Sub Form_Load()

   Dim msg As String
   
   Command1.Caption = "Send Email"
   Option1(1).Value = True
   
   Text1.Text = "me@123.com"
   Text2.Text = "recipient@123.com"
   Text3.Text = "ccperson@123.com"
   Text4.Text = "bccperson@123.com"
   Text5.Text = "VBnet ShellExecute Test Message"
   
  'a long message
   msg = msg & "Since beginning VBnet in November of 1996, "
   msg = msg & "I have been repeatedly asked why I don't (or won't) "
   msg = msg & "provide the code methodologies and projects "
   msg = msg & "presented here in a downloadable format like "
   msg = msg & "other sites do." & vbCrLf & vbCrLf
   msg = msg & "The decision to present the site as code (text) "
   msg = msg & "pages instead of zip files was not one that I "
   msg = msg & "made lightly. Frankly, just providing downloadable "
   msg = msg & "files is certainly easier than creating and "
   msg = msg & "maintaining individual pages for each code topic."
   msg = msg & "However, given my reasons below, I believe that "
   msg = msg & "the VBnet text presentation method benefits more "
   msg = msg & "than downloads could." & vbCrLf & vbCrLf
   msg = msg & "Providing the code as HTML pages is not without "
   msg = msg & "its frustrations. There's the issue of HTML and "
   msg = msg & "the 'not equal' signs; HTML interpreters ignore "
   msg = msg & "these VB operators because they expect to find "
   msg = msg & "HTML formatting commands inside. There's the issue "
   msg = msg & "of assuring hard returns are correctly interpreted, "
   msg = msg & "and that non-breaking spaces don't find their "
   msg = msg & "way into the code (which wrecks havoc in the IDE). "
   msg = msg & "Add to this assuring no code from the development "
   msg = msg & "project is inadvertently omitted, all the while "
   msg = msg & "keeping in mind potential compatibility problems "
   msg = msg & "between presentation in Internet Explorer and Netscape."
   msg = msg & vbCrLf & vbCrLf
   msg = msg & "Challenges aside, VBnet provides the opportunity to "
   msg = msg & "share what I have learned pouring through the MSDN "
   msg = msg & "and other API references, and have received from "
   msg = msg & "friends and contributors, as well as the bonus of "
   msg = msg & "allowing me to experiment with web site design. "
   Text6.Text = msg
   
End Sub


Private Sub Command1_Click()

   Dim email As EmailInfo
   Dim msg As String
   Dim sTmpFile As String
   Dim hFile As Long
   
  'the temp email file
   sTmpFile = App.Path & "\temp.eml"
   
  'complete the fields to be used
   With email
      .sAddrFrom = Text1.Text
      .sAddrTo = Text2.Text
      .sAddrCC = Text3.Text
      .sAddrBCC = Text4.Text
      .sSubject = Text5.Text
      .sMessage = Text6.Text
      .sPriority = (GetSelectedOptionIndex() * 2) + 1
   End With
   
  'create the temp file
   hFile = EmailCreate(sTmpFile)
   
  'if successful,
   If hFile <> 0 Then
   
     'write out the data and
     'send the email
      If EmailWrite(hFile, email) Then
      
         RunShellExecute "Open", _
                         sTmpFile, _
                         vbNullString, _
                         vbNullString, _
                         vbNormalFocus
      
      End If
   
   End If
   
End Sub


Private Function GetSelectedOptionIndex() As Long

  'returns the selected item index from
  'an option button array. Use in place
  'of multiple If...Then statements!
  'If your array contains more elements,
  'just append them to the test condition,
  'setting the multiplier to the button's
  'negative -index.
   GetSelectedOptionIndex = Option1(0).Value * 0 Or _
                            Option1(1).Value * -1 Or _
                            Option1(2).Value * -2
End Function



Private Sub RunShellExecute(sAddrTopic As String, _
                           sFile As Variant, _
                           sParams As Variant, _
                           sDirectory As Variant, _
                           nShowCmd As Long)

   Dim hWndDesk As Long
   Dim success As Long
  
  'the desktop will be the
  'default for error messages
   hWndDesk = GetDesktopWindow()
  
  'execute the passed operation
   success = ShellExecute(hWndDesk, _
                          sAddrTopic, _
                          sFile, _
                          sParams, _
                          sDirectory, _
                          nShowCmd)

  'This is optional. Uncomment the three lines
  'below to have the "Open With.." dialog appear
  'when the ShellExecute API call fails
  'If success < 32 Then
  '   Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " & sFile, vbNormalFocus)
  'End If
   
End Sub


Private Function EmailCreate(sTmpFile) As Long

   Dim hFile As Long
   
   hFile = FreeFile
   Open sTmpFile For Output As #hFile
   
   EmailCreate = hFile
   
End Function


Private Function EmailWrite(ByVal hFile As Long, email As EmailInfo) As Boolean

  'write the email fields to the file
   
   Print #hFile, "From: <"; email.sAddrFrom; ">"
   
   If Len(email.sAddrTo) Then
      Print #hFile, "To: "; Chr$(34); email.sAddrTo; Chr$(34)
   Else
     'no to address, so bail
      EmailWrite = False
      Exit Function
   End If
   
   If Len(email.sAddrCC) Then
      Print #hFile, "CC: "; Chr$(34); email.sAddrCC; Chr$(34)
   End If
      
   If Len(email.sAddrBCC) Then
      Print #hFile, "BCC: "; Chr$(34); email.sAddrBCC; Chr$(34)
   End If
   
   Print #hFile, "Subject: "; email.sSubject
   Print #hFile, "X-Priority:"; email.sPriority   '1=high,3=normal,5=low
   
  'this is the last header line - everything
  'after this appears in the message.
   Print #hFile, "X-Unsent: 1"
   Print #hFile, ""    'Blank line
   Print #hFile, email.sMessage
   
   Close #hFile
   
   EmailWrite = True

End Function