'------------------------------------------------------
'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
