VpnDial/src/Module_Main.bas

Attribute VB_Name = "Module_Main"
Option Explicit

' see: How To Obtain the IP Address Assigned to a RAS Client
' http://support.microsoft.com/default.aspx?scid=kb;en-us;160622

' see: RasGetProjectionInfo
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcecomm5/html/wce50lrfRasGetProjectionInfo.asp

' http://home.iprimus.com.au/billmcc/PlatformVB/dun/rasenumentries.htm
' http://home.iprimus.com.au/billmcc/PlatformVB/dun/raserrorhandler.htm
' http://www.mentalis.org/apilist/RasEnumEntries.shtml

' http://www.activevb.de/tipps/tipkat/kat1.html
' http://www.activevb.de/rubriken/apikatalog/deklarationen/rasenumentries.html
' http://www.dotnet247.com/247reference/msgs/18/93960.aspx

' contains all ras entry objects
Public RasEntries As New Collection

' globals to store connection name and state
Public ConnectionName As String
Public ConnectionOnline As Boolean

' globals to store information about action to do on up|down
Enum ActionTypes
    RUN_SCRIPT
    ADD_ROUTE
End Enum
Public ActionType As ActionTypes

Public ScriptName As String
Public RouteNet As String, RouteMask As String

Const RouteMaskDefault As String = "255.255.255.0"


Sub Main()

    Dim cmdline As New CommandLine
    Dim conName As String
    Dim rasItem As RasEntryData
    Dim success As Boolean
    
    Dim script_name As String, script_args As String
    Dim setup_user As String, setup_pass As String

    ReadRasEntries
    cmdline.parse
    
    'If cmdline.hasSwitch("gui") Then
    '    Form_Main.Show
    'Else
        
    ' run script
    If cmdline.hasSwitch("script") And success = True Then
        script_name = cmdline.getArgument("script")
        If script_name <> "" Then
            script_args = Chr(34) & DetermineClientIP(conName) & Chr(34) & " " & Chr(34) & DetermineServerIP(conName) & Chr(34)
            Shell App.Path & "\" & script_name & " " & script_args, vbHide
        End If
    'End If
    
    ' setup
    ElseIf cmdline.hasSwitch("setup") Then
        conName = cmdline.getArgument("setup")
        If conName <> "" Then
        
            On Error Resume Next
            Set rasItem = RasEntries(conName)
            If Err.Number <> 0 Then
                MsgBox "Error while accessing RAS entry """ & conName & """." & vbCrLf & "Probably it does not exist?"
                End
            End If
            On Error GoTo 0
        
            If cmdline.hasSwitch("gui") Then
                With Form_Credentials
                    .ras_connectionName = rasItem.entryname
                    .ras_phoneBook = rasItem.PhonebookPath
                    .Show
                End With
        
            ElseIf cmdline.hasSwitch("user") And cmdline.hasSwitch("pass") Then
                setup_user = cmdline.getArgument("user")
                setup_pass = cmdline.getArgument("pass")
                SetupRasEntry rasItem.entryname, rasItem.PhonebookPath, setup_user, setup_pass
            End If
        
        End If
    
    ' monitor
    ElseIf cmdline.hasSwitch("monitor") Then
        conName = cmdline.getArgument("monitor")
        If conName <> "" Then
        
            ' run script
            If cmdline.hasSwitch("script") Then
                ActionType = RUN_SCRIPT
                ScriptName = cmdline.getArgument("script")
            End If
        
            ' add a route with target network via gateway
            If cmdline.hasSwitch("net") Then
                ActionType = ADD_ROUTE
                RouteNet = cmdline.getArgument("net")
                If cmdline.hasSwitch("mask") Then
                    RouteMask = cmdline.getArgument("mask")
                Else
                    RouteMask = RouteMaskDefault
                End If
            End If
        
            'Set rasItem = RasEntries(conName)
            'RasRetrieveConnectionHandler conName
            ConnectionName = conName
            ConnectionOnline = RasIsOnline(conName)
            
            If cmdline.hasSwitch("gui") Then
                ShowTrayIcon Form_Main, getTrayIconTipText(ConnectionName, ConnectionOnline)
            End If
            
            ' dial command
            If cmdline.hasSwitch("dial") Then
                doDial conName
            End If
            
            ' monitor ras connection
            MonitorRASStatusAsync
            
        End If

    ' dial command
    ElseIf cmdline.hasSwitch("dial") Then
        conName = cmdline.getArgument("dial")
        doDial conName
    
    ' hangup command
    ElseIf cmdline.hasSwitch("hangup") Then
        conName = cmdline.getArgument("hangup")
        success = RasDisconnect(conName)
        'MsgBox success

    End If
        
    'End If
    
End Sub

Private Sub ReadRasEntries()

    Dim myEntries() As VBRasEntryName
    Dim lngCount As Long
    Dim rasItem As RasEntryData
    
    lngCount = VBRasGetAllEntries(myEntries)
    
    'MsgBox lngCount
    Dim i As Integer
    Dim curEntry As VBRasEntryName
    For i = 0 To lngCount - 1
        curEntry = myEntries(i)
        
        Set rasItem = New RasEntryData
        rasItem.entryname = curEntry.entryname
        rasItem.PhonebookPath = curEntry.PhonebookPath
        rasItem.Win2000_SystemPhonebook = curEntry.Win2000_SystemPhonebook
        
        'MsgBox rasItem.entryname
        On Error Resume Next
        RasEntries.add rasItem, rasItem.entryname
        If Err.Number = 457 Then
            'MsgBox "Error: Duplicate RAS entry. Don't know what to dial. This error should not occour."
        End If
        On Error GoTo 0
    Next i

End Sub

' callback from MonitorRASStatusAsync
Public Sub detectOnlineOfflineChange()
    Dim isOnline As Boolean
    Dim script_name As String, script_args As String
    Dim cmd As String
    
    isOnline = RasIsOnline(ConnectionName)
    
    If ConnectionOnline <> isOnline Then
        'MsgBox isOnline
        
        Select Case ActionType
            
            Case RUN_SCRIPT:
                script_name = ScriptName
                If script_name <> "" Then
                    script_args = Chr(34) & DetermineClientIP(ConnectionName) & Chr(34) & " " & Chr(34) & DetermineServerIP(ConnectionName) & Chr(34)
                    cmd = App.Path & "\" & script_name & " " & script_args
                End If
                
            Case ADD_ROUTE:
                ' connection goes online
                If isOnline = True Then
                    script_name = "route"
                    script_args = "add " & RouteNet & " mask " & RouteMask & " " & DetermineClientIP(ConnectionName)
                    cmd = script_name & " " & script_args
                
                ' connection goes offline
                Else
                    ' Nothing to do in this case
                
                End If
            
        End Select
        
        If cmd <> "" Then
            'MsgBox cmd
            On Error Resume Next
            Shell cmd, vbHide
            'Shell cmd, vbNormalFocus
            'If Err.Number <> 0 Then
            '    MsgBox "Error while calling cmd: " & cmd & vbCrLf & "Error-Number: " & Err.Number
            'End If
            On Error GoTo 0
        End If
        
        ConnectionOnline = isOnline
        
        UpdateTrayIcon getTrayIconTipText(ConnectionName, ConnectionOnline)
        
    End If
End Sub

Private Function getTrayIconTipText(conName As String, isOnline As Boolean) As String
    Dim TipText As String
    TipText = "VpnDial monitoring """ & conName & """: "
    If isOnline Then
        TipText = TipText & "online"
    Else
        TipText = TipText & "offline"
    End If
    getTrayIconTipText = TipText
End Function


Private Function doDial(conName As String)

    Dim rasItem As RasEntryData
    Dim success As Boolean

    On Error Resume Next
    Set rasItem = RasEntries(conName)
    If Err.Number = 0 Then
        success = RasConnect(rasItem.entryname, rasItem.PhonebookPath)
    Else
        MsgBox "Unknown RAS-Connection """ & conName & """."
    End If
    On Error GoTo 0

End Function
1	Attribute VB_Name = "Module_Main"
2	Option Explicit
3
4	' see: How To Obtain the IP Address Assigned to a RAS Client
5	' http://support.microsoft.com/default.aspx?scid=kb;en-us;160622
6
7	' see: RasGetProjectionInfo
8	' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wcecomm5/html/wce50lrfRasGetProjectionInfo.asp
9
10	' http://home.iprimus.com.au/billmcc/PlatformVB/dun/rasenumentries.htm
11	' http://home.iprimus.com.au/billmcc/PlatformVB/dun/raserrorhandler.htm
12	' http://www.mentalis.org/apilist/RasEnumEntries.shtml
13
14	' http://www.activevb.de/tipps/tipkat/kat1.html
15	' http://www.activevb.de/rubriken/apikatalog/deklarationen/rasenumentries.html
16	' http://www.dotnet247.com/247reference/msgs/18/93960.aspx
17
18	' contains all ras entry objects
19	Public RasEntries As New Collection
20
21	' globals to store connection name and state
22	Public ConnectionName As String
23	Public ConnectionOnline As Boolean
24
25	' globals to store information about action to do on up\|down
26	Enum ActionTypes
27	RUN_SCRIPT
28	ADD_ROUTE
29	End Enum
30	Public ActionType As ActionTypes
31
32	Public ScriptName As String
33	Public RouteNet As String, RouteMask As String
34
35	Const RouteMaskDefault As String = "255.255.255.0"
36
37
38	Sub Main()
39
40	Dim cmdline As New CommandLine
41	Dim conName As String
42	Dim rasItem As RasEntryData
43	Dim success As Boolean
44
45	Dim script_name As String, script_args As String
46	Dim setup_user As String, setup_pass As String
47
48	ReadRasEntries
49	cmdline.parse
50
51	'If cmdline.hasSwitch("gui") Then
52	' Form_Main.Show
53	'Else
54
55	' run script
56	If cmdline.hasSwitch("script") And success = True Then
57	script_name = cmdline.getArgument("script")
58	If script_name <> "" Then
59	script_args = Chr(34) & DetermineClientIP(conName) & Chr(34) & " " & Chr(34) & DetermineServerIP(conName) & Chr(34)
60	Shell App.Path & "\" & script_name & " " & script_args, vbHide
61	End If
62	'End If
63
64	' setup
65	ElseIf cmdline.hasSwitch("setup") Then
66	conName = cmdline.getArgument("setup")
67	If conName <> "" Then
68
69	On Error Resume Next
70	Set rasItem = RasEntries(conName)
71	If Err.Number <> 0 Then
72	MsgBox "Error while accessing RAS entry """ & conName & """." & vbCrLf & "Probably it does not exist?"
73	End
74	End If
75	On Error GoTo 0
76
77	If cmdline.hasSwitch("gui") Then
78	With Form_Credentials
79	.ras_connectionName = rasItem.entryname
80	.ras_phoneBook = rasItem.PhonebookPath
81	.Show
82	End With
83
84	ElseIf cmdline.hasSwitch("user") And cmdline.hasSwitch("pass") Then
85	setup_user = cmdline.getArgument("user")
86	setup_pass = cmdline.getArgument("pass")
87	SetupRasEntry rasItem.entryname, rasItem.PhonebookPath, setup_user, setup_pass
88	End If
89
90	End If
91
92	' monitor
93	ElseIf cmdline.hasSwitch("monitor") Then
94	conName = cmdline.getArgument("monitor")
95	If conName <> "" Then
96
97	' run script
98	If cmdline.hasSwitch("script") Then
99	ActionType = RUN_SCRIPT
100	ScriptName = cmdline.getArgument("script")
101	End If
102
103	' add a route with target network via gateway
104	If cmdline.hasSwitch("net") Then
105	ActionType = ADD_ROUTE
106	RouteNet = cmdline.getArgument("net")
107	If cmdline.hasSwitch("mask") Then
108	RouteMask = cmdline.getArgument("mask")
109	Else
110	RouteMask = RouteMaskDefault
111	End If
112	End If
113
114	'Set rasItem = RasEntries(conName)
115	'RasRetrieveConnectionHandler conName
116	ConnectionName = conName
117	ConnectionOnline = RasIsOnline(conName)
118
119	If cmdline.hasSwitch("gui") Then
120	ShowTrayIcon Form_Main, getTrayIconTipText(ConnectionName, ConnectionOnline)
121	End If
122
123	' dial command
124	If cmdline.hasSwitch("dial") Then
125	doDial conName
126	End If
127
128	' monitor ras connection
129	MonitorRASStatusAsync
130
131	End If
132
133	' dial command
134	ElseIf cmdline.hasSwitch("dial") Then
135	conName = cmdline.getArgument("dial")
136	doDial conName
137
138	' hangup command
139	ElseIf cmdline.hasSwitch("hangup") Then
140	conName = cmdline.getArgument("hangup")
141	success = RasDisconnect(conName)
142	'MsgBox success
143
144	End If
145
146	'End If
147
148	End Sub
149
150	Private Sub ReadRasEntries()
151
152	Dim myEntries() As VBRasEntryName
153	Dim lngCount As Long
154	Dim rasItem As RasEntryData
155
156	lngCount = VBRasGetAllEntries(myEntries)
157
158	'MsgBox lngCount
159	Dim i As Integer
160	Dim curEntry As VBRasEntryName
161	For i = 0 To lngCount - 1
162	curEntry = myEntries(i)
163
164	Set rasItem = New RasEntryData
165	rasItem.entryname = curEntry.entryname
166	rasItem.PhonebookPath = curEntry.PhonebookPath
167	rasItem.Win2000_SystemPhonebook = curEntry.Win2000_SystemPhonebook
168
169	'MsgBox rasItem.entryname
170	On Error Resume Next
171	RasEntries.add rasItem, rasItem.entryname
172	If Err.Number = 457 Then
173	'MsgBox "Error: Duplicate RAS entry. Don't know what to dial. This error should not occour."
174	End If
175	On Error GoTo 0
176	Next i
177
178	End Sub
179
180	' callback from MonitorRASStatusAsync
181	Public Sub detectOnlineOfflineChange()
182	Dim isOnline As Boolean
183	Dim script_name As String, script_args As String
184	Dim cmd As String
185
186	isOnline = RasIsOnline(ConnectionName)
187
188	If ConnectionOnline <> isOnline Then
189	'MsgBox isOnline
190
191	Select Case ActionType
192
193	Case RUN_SCRIPT:
194	script_name = ScriptName
195	If script_name <> "" Then
196	script_args = Chr(34) & DetermineClientIP(ConnectionName) & Chr(34) & " " & Chr(34) & DetermineServerIP(ConnectionName) & Chr(34)
197	cmd = App.Path & "\" & script_name & " " & script_args
198	End If
199
200	Case ADD_ROUTE:
201	' connection goes online
202	If isOnline = True Then
203	script_name = "route"
204	script_args = "add " & RouteNet & " mask " & RouteMask & " " & DetermineClientIP(ConnectionName)
205	cmd = script_name & " " & script_args
206
207	' connection goes offline
208	Else
209	' Nothing to do in this case
210
211	End If
212
213	End Select
214
215	If cmd <> "" Then
216	'MsgBox cmd
217	On Error Resume Next
218	Shell cmd, vbHide
219	'Shell cmd, vbNormalFocus
220	'If Err.Number <> 0 Then
221	' MsgBox "Error while calling cmd: " & cmd & vbCrLf & "Error-Number: " & Err.Number
222	'End If
223	On Error GoTo 0
224	End If
225
226	ConnectionOnline = isOnline
227
228	UpdateTrayIcon getTrayIconTipText(ConnectionName, ConnectionOnline)
229
230	End If
231	End Sub
232
233	Private Function getTrayIconTipText(conName As String, isOnline As Boolean) As String
234	Dim TipText As String
235	TipText = "VpnDial monitoring """ & conName & """: "
236	If isOnline Then
237	TipText = TipText & "online"
238	Else
239	TipText = TipText & "offline"
240	End If
241	getTrayIconTipText = TipText
242	End Function
243
244
245	Private Function doDial(conName As String)
246
247	Dim rasItem As RasEntryData
248	Dim success As Boolean
249
250	On Error Resume Next
251	Set rasItem = RasEntries(conName)
252	If Err.Number = 0 Then
253	success = RasConnect(rasItem.entryname, rasItem.PhonebookPath)
254	Else
255	MsgBox "Unknown RAS-Connection """ & conName & """."
256	End If
257	On Error GoTo 0
258
259	End Function
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26