Internet, Web & Mail Stuff

Read text box and Launch Default Browser.
Strip attachments from email in Outlook.

Got a useful snippet you'd like to share? Submit it here.

'------------------------------------------------------
'Author:Don (Donzo) Zieler
'Posted:5/26/98
'webmaster@dad.win.net      webmaster@cd-mall.com
'http://www.win.net/dad     http://www.cd-mall.com
'
'Here's some code to read a text box and start the 
'default browser to go to the site. It works really well 
'in a phone book program I wrote! I wrote this in VB 5.0  
'Let me know what you think. 
'------------------------------------------------------
'OBJECTS to create for this code:
'text box named txtWeb  with the text set to http://www.
'button named cmdWeb
 
' Place this in a BAS module
Dim success As Integer
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

'------------------------------------------------------------------
 
'Here's the button code
Private Sub cmdWeb_Click()
Dim success As Integer
If Trim(txtWeb.Text) = "http://www." Or Trim(txtWeb.Text) = "" Then ' I have the txtWeb.text set to http://www. 
    MsgBox "You don't have a web address entered for this entry", vbCritical, "Missing Data"
ElseIf Left(Trim(txtWeb.Text), 11) = "http://www." Then
    Site = Trim(txtWeb.Text)
    ElseIf Left(Trim(txtWeb.Text), 4) = "www." Then
    Site = "http://" & Trim(txtWeb.Text)
    Else
Site = "http://www." & Trim(txtWeb.Text)
End If
success% = ShellToBrowser(Me, Site, 0)
End Sub
'------------------------------------------------------------------
 
' Here's the function code
Function ShellToBrowser%(Frm As Form, ByVal URL$, ByVal WindowStyle%)
    
    Dim api%
        api% = ShellExecute(Frm.hwnd, "open", URL$, "", App.Path, WindowStyle%)
 
    'Check return value
    If api% <31 Then
        'error code - see api help for more info
        MsgBox App.Title & " had a problem running your web browser. & _
          "You should check that your browser is correctly installed." & _
          (Error" & Format$(api%) & ")", 48, "Browser Unavailable"
        ShellToBrowser% = False
    ElseIf api% = 32 Then
        'no file association
        MsgBox App.Title & " could not find a file association for " & _
          URL$ & " on your system. You should check that your browser" & _
          "is correctly installed and associated with this type of file.", 48, "Browser Unavailable"
        ShellToBrowser% = False
    Else
        'It worked!
        ShellToBrowser% = True
 
    End If
    
End Function
 
'------------------------------------------------------------------
' If you want to create an email address in a text box and start your email
' program add this code and  txtEmail  and cmdEmail to the same page
' it uses the same function 
 
' Here's the button code
 
Private Sub cmdEmail_Click()
Dim success As Integer
If Trim(txtEmail.Text) = "" Then  ' Give an error if nothing is in the text box
        MsgBox "You don't have an email address entered for this entry", vbCritical, "Missing Data"
        Else
Site = "mailto:" & Trim(txtEmail.Text)
success% = ShellToBrowser(Me, Site, 0)
End If
End Sub                                        



'------------------------------------------------------
'Author: Lewis Cornick
'Date   : 04/22/98
'http://www.geocities.com/SiliconValley/Haven/1768
'E-Mail:l_cornick@hotmail.com

'Description: To be used in 'stripping' attachments from 
'e-mails in your inbox and save them to a hardcoded path.
'------------------------------------------------------
'This bit of code will strip attachments and save them into the path
'"C:\temp\Outlook Attachments", it has no error handling so be warned!
'Code starts (placed under a command button.)

Dim oApp As Outlook.Application
Dim oNameSpace As NameSpace
Dim oFolder As MAPIFolder
Dim oMailItem As Object
Dim sMessage As String

Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox)

    For Each oMailItem In oFolder.Items
        With oMailItem
            If oMailItem.Attachments.Count > 0 Then '?
               oMailItem.Attachments.Item(1).SaveAsFile "C:\Temp\Outlook
Attachments\" & oMailItem.Attachments.Item(1).filename
               MsgBox oMailItem.Attachments.Item(1).DisplayName & " was
saved as " & oMailItem.Attachments.Item(1).filename
            End If
        End With
    Next oMailItem

Set oMailItem = Nothing
Set oFolder = Nothing
Set oNameSpace = Nothing
Set oApp = Nothing