Membuka Browser dengan alamat yang ada di text box

1. '------------------------------------------------- -----  
2.      'Object untuk membuat Project ini:  
3.      'TextBox bernama txtWeb dengan teks diatur ke http://www.  
4.      'tombol bernama cmdWeb  
5.        
6.     ' Listing module  
7.     Dim success As Integer  
8.     Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _  
9.     (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _   
10.     ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long  
11.   
12.     '------------------------------------------------------------------  
13.        
14.     'Listing Tombol  
15.     Private Sub cmdWeb_Click()  
16.     Dim success As Integer  
17.     If Trim(txtWeb.Text) = "http://www." Or Trim(txtWeb.Text) = "" Then ' I have the txtWeb.text set to http://www.   
18.         MsgBox "You don't have a web address entered for this entry", vbCritical, "Missing Data"  
19.     ElseIf Left(Trim(txtWeb.Text), 11) = "http://www." Then  
20.         Site = Trim(txtWeb.Text)  
21.         ElseIf Left(Trim(txtWeb.Text), 4) = "www." Then  
22.         Site = "http://" & Trim(txtWeb.Text)  
23.         Else  
24.     Site = "http://www." & Trim(txtWeb.Text)  
25.     End If  
26.     success% = ShellToBrowser(Me, Site, 0)  
27.     End Sub  
28.     '------------------------------------------------------------------  
29.        
30.     ' Here's the function code  
31.     Function ShellToBrowser%(Frm As Form, ByVal URL$, ByVal WindowStyle%)  
32.           
33.         Dim api%  
34.             api% = ShellExecute(Frm.hwnd, "open", URL$, "", App.Path, WindowStyle%)  
35.        
36.         'Check return value  
37.         If api% <31 Then  
38.             'error code - see api help for more info  
39.             MsgBox App.Title & " had a problem running your web browser. & _ 
40.               "You should check that your browser is correctly installed." & _ 
41.               (Error" & Format$(api%) & ")", 48, "Browser Unavailable"  
42.             ShellToBrowser% = False  
43.         ElseIf api% = 32 Then  
44.             'no file association  
45.             MsgBox App.Title & " could not find a file association for " & _  
46.               URL$ & " on your system. You should check that your browser" & _  
47.               "is correctly installed and associated with this type of file.", 48, "Browser Unavailable"  
48.             ShellToBrowser% = False  
49.         Else  
50.             'It worked!  
51.             ShellToBrowser% = True  
52.        
53.         End If  
54.           
55.     End Function  
56.   
57.        
58.     Private Sub cmdEmail_Click()  
59.     Dim success As Integer  
60.     If Trim(txtEmail.Text) = "" Then  ' Give an error if nothing is in the text box  
61.             MsgBox "You don't have an email address entered for this entry", vbCritical, "Missing Data"  
62.             Else  
63.     Site = "mailto:" & Trim(txtEmail.Text)  
64.     success% = ShellToBrowser(Me, Site, 0)  
65.     End If  
66.     End Sub                                          
67.   
68. Dim oApp As Outlook.Application  
69. Dim oNameSpace As NameSpace  
70. Dim oFolder As MAPIFolder  
71. Dim oMailItem As Object  
72. Dim sMessage As String  
73.   
74. Set oApp = New Outlook.Application  
75. Set oNameSpace = oApp.GetNamespace("MAPI")  
76. Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox)  
77.   
78.     For Each oMailItem In oFolder.Items  
79.         With oMailItem  
80.             If oMailItem.Attachments.Count > 0 Then '?  
81.                oMailItem.Attachments.Item(1).SaveAsFile "C:\Temp\Outlook 
82. Attachments\" & oMailItem.Attachments.Item(1).filename 
83.                MsgBox oMailItem.Attachments.Item(1).DisplayName & " was  
84. saved as " & oMailItem.Attachments.Item(1).filename  
85.             End If  
86.         End With  
87.     Next oMailItem  
88.   
89. Set oMailItem = Nothing  
90. Set oFolder = Nothing  
91. Set oNameSpace = Nothing  
92. Set oApp = Nothing  

---

Klik Like/share jika anda menyukai tulisan Share