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	joko	1.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	joko	1.6	' contains all ras entry objects
19	joko	1.1	Public RasEntries As New Collection
20	joko	1.6
21			' globals to store connection name and state
22	joko	1.4	Public ConnectionName As String
23			Public ConnectionOnline As Boolean
24	joko	1.6
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	joko	1.1
38			Sub Main()
39
40			Dim cmdline As New CommandLine
41			Dim conName As String
42	joko	1.2	Dim rasItem As RasEntryData
43			Dim success As Boolean
44	joko	1.3
45			Dim script_name As String, script_args As String
46			Dim setup_user As String, setup_pass As String
47	joko	1.1
48			ReadRasEntries
49			cmdline.parse
50
51	joko	1.3	'If cmdline.hasSwitch("gui") Then
52			' Form_Main.Show
53			'Else
54	joko	1.2
55	joko	1.3	' run script
56	joko	1.9	If cmdline.hasSwitch("script") And success = True Then
57	joko	1.3	script_name = cmdline.getArgument("script")
58			If script_name <> "" Then
59	joko	1.5	script_args = Chr(34) & DetermineClientIP(conName) & Chr(34) & " " & Chr(34) & DetermineServerIP(conName) & Chr(34)
60	joko	1.3	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	joko	1.2
69	joko	1.8	On Error Resume Next
70	joko	1.3	Set rasItem = RasEntries(conName)
71	joko	1.8	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	joko	1.2
77	joko	1.3	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	joko	1.2	End If
89	joko	1.3
90	joko	1.2	End If
91	joko	1.4
92			' monitor
93			ElseIf cmdline.hasSwitch("monitor") Then
94			conName = cmdline.getArgument("monitor")
95			If conName <> "" Then
96
97	joko	1.6	' run script
98			If cmdline.hasSwitch("script") Then
99			ActionType = RUN_SCRIPT
100			ScriptName = cmdline.getArgument("script")
101	joko	1.4	End If
102
103	joko	1.6	' 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	joko	1.4	End If
113
114			'Set rasItem = RasEntries(conName)
115			'RasRetrieveConnectionHandler conName
116			ConnectionName = conName
117			ConnectionOnline = RasIsOnline(conName)
118	joko	1.8
119			If cmdline.hasSwitch("gui") Then
120			ShowTrayIcon Form_Main, getTrayIconTipText(ConnectionName, ConnectionOnline)
121			End If
122
123	joko	1.9	' dial command
124			If cmdline.hasSwitch("dial") Then
125			doDial conName
126			End If
127
128			' monitor ras connection
129	joko	1.4	MonitorRASStatusAsync
130	joko	1.9
131	joko	1.4	End If
132
133	joko	1.9	' 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	joko	1.3	End If
145	joko	1.2
146	joko	1.3	'End If
147	joko	1.1
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	joko	1.8	'MsgBox rasItem.entryname
170			On Error Resume Next
171	joko	1.1	RasEntries.add rasItem, rasItem.entryname
172	joko	1.8	If Err.Number = 457 Then
173	joko	1.9	'MsgBox "Error: Duplicate RAS entry. Don't know what to dial. This error should not occour."
174	joko	1.8	End If
175			On Error GoTo 0
176	joko	1.1	Next i
177
178			End Sub
179	joko	1.4
180			' callback from MonitorRASStatusAsync
181			Public Sub detectOnlineOfflineChange()
182	joko	1.6	Dim isOnline As Boolean
183	joko	1.4	Dim script_name As String, script_args As String
184			Dim cmd As String
185
186	joko	1.6	isOnline = RasIsOnline(ConnectionName)
187	joko	1.4
188	joko	1.6	If ConnectionOnline <> isOnline Then
189			'MsgBox isOnline
190	joko	1.4
191	joko	1.6	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	joko	1.4
215	joko	1.6	If cmd <> "" Then
216	joko	1.4	'MsgBox cmd
217			On Error Resume Next
218			Shell cmd, vbHide
219	joko	1.7	'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	joko	1.4	On Error GoTo 0
224			End If
225
226	joko	1.6	ConnectionOnline = isOnline
227	joko	1.8
228			UpdateTrayIcon getTrayIconTipText(ConnectionName, ConnectionOnline)
229
230	joko	1.4	End If
231			End Sub
232	joko	1.8
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	joko	1.9
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