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
        
    ' dial command
    If cmdline.hasSwitch("dial") Then
    
        conName = cmdline.getArgument("dial")
        On Error Resume Next
        Set rasItem = RasEntries(conName)
        If Err.Number = 0 Then
            success = RasConnect(rasItem.entryname, rasItem.PhonebookPath)
        Else
            MsgBox "Unkown RAS-Connection """ & conName & """."
        End If
        On Error GoTo 0
    
    ' hangup command
    ElseIf cmdline.hasSwitch("hangup") Then
        conName = cmdline.getArgument("hangup")
        success = RasDisconnect(conName)
        'MsgBox success
    
    'End If
    
    ' run script
    ElseIf 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
            
            MonitorRASStatusAsync
        End If

    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
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	' dial command
56			If cmdline.hasSwitch("dial") Then
57
58			conName = cmdline.getArgument("dial")
59			On Error Resume Next
60			Set rasItem = RasEntries(conName)
61			If Err.Number = 0 Then
62			success = RasConnect(rasItem.entryname, rasItem.PhonebookPath)
63			Else
64			MsgBox "Unkown RAS-Connection """ & conName & """."
65			End If
66			On Error GoTo 0
67
68			' hangup command
69			ElseIf cmdline.hasSwitch("hangup") Then
70			conName = cmdline.getArgument("hangup")
71			success = RasDisconnect(conName)
72			'MsgBox success
73
74			'End If
75
76			' run script
77			ElseIf cmdline.hasSwitch("script") And success = True Then
78			script_name = cmdline.getArgument("script")
79			If script_name <> "" Then
80	joko	1.5	script_args = Chr(34) & DetermineClientIP(conName) & Chr(34) & " " & Chr(34) & DetermineServerIP(conName) & Chr(34)
81	joko	1.3	Shell App.Path & "\" & script_name & " " & script_args, vbHide
82			End If
83			'End If
84
85			' setup
86			ElseIf cmdline.hasSwitch("setup") Then
87			conName = cmdline.getArgument("setup")
88			If conName <> "" Then
89	joko	1.2
90	joko	1.8	On Error Resume Next
91	joko	1.3	Set rasItem = RasEntries(conName)
92	joko	1.8	If Err.Number <> 0 Then
93			MsgBox "Error while accessing RAS entry """ & conName & """." & vbCrLf & "Probably it does not exist?"
94			End
95			End If
96			On Error GoTo 0
97	joko	1.2
98	joko	1.3	If cmdline.hasSwitch("gui") Then
99			With Form_Credentials
100			.ras_connectionName = rasItem.entryname
101			.ras_phoneBook = rasItem.PhonebookPath
102			.Show
103			End With
104
105			ElseIf cmdline.hasSwitch("user") And cmdline.hasSwitch("pass") Then
106			setup_user = cmdline.getArgument("user")
107			setup_pass = cmdline.getArgument("pass")
108			SetupRasEntry rasItem.entryname, rasItem.PhonebookPath, setup_user, setup_pass
109	joko	1.2	End If
110	joko	1.3
111	joko	1.2	End If
112	joko	1.4
113			' monitor
114			ElseIf cmdline.hasSwitch("monitor") Then
115			conName = cmdline.getArgument("monitor")
116			If conName <> "" Then
117
118	joko	1.6	' run script
119			If cmdline.hasSwitch("script") Then
120			ActionType = RUN_SCRIPT
121			ScriptName = cmdline.getArgument("script")
122	joko	1.4	End If
123
124	joko	1.6	' add a route with target network via gateway
125			If cmdline.hasSwitch("net") Then
126			ActionType = ADD_ROUTE
127			RouteNet = cmdline.getArgument("net")
128			If cmdline.hasSwitch("mask") Then
129			RouteMask = cmdline.getArgument("mask")
130			Else
131			RouteMask = RouteMaskDefault
132			End If
133	joko	1.4	End If
134
135			'Set rasItem = RasEntries(conName)
136			'RasRetrieveConnectionHandler conName
137			ConnectionName = conName
138			ConnectionOnline = RasIsOnline(conName)
139	joko	1.8
140			If cmdline.hasSwitch("gui") Then
141			ShowTrayIcon Form_Main, getTrayIconTipText(ConnectionName, ConnectionOnline)
142			End If
143
144	joko	1.4	MonitorRASStatusAsync
145			End If
146
147	joko	1.3	End If
148	joko	1.2
149	joko	1.3	'End If
150	joko	1.1
151			End Sub
152
153			Private Sub ReadRasEntries()
154
155			Dim myEntries() As VBRasEntryName
156			Dim lngCount As Long
157			Dim rasItem As RasEntryData
158
159			lngCount = VBRasGetAllEntries(myEntries)
160
161			'MsgBox lngCount
162			Dim i As Integer
163			Dim curEntry As VBRasEntryName
164			For i = 0 To lngCount - 1
165			curEntry = myEntries(i)
166
167			Set rasItem = New RasEntryData
168			rasItem.entryname = curEntry.entryname
169			rasItem.PhonebookPath = curEntry.PhonebookPath
170			rasItem.Win2000_SystemPhonebook = curEntry.Win2000_SystemPhonebook
171
172	joko	1.8	'MsgBox rasItem.entryname
173			On Error Resume Next
174	joko	1.1	RasEntries.add rasItem, rasItem.entryname
175	joko	1.8	If Err.Number = 457 Then
176			MsgBox "Error: Duplicate RAS entry. Don't know what to dial. This error should not occour."
177			End If
178			On Error GoTo 0
179	joko	1.1	Next i
180
181			End Sub
182	joko	1.4
183			' callback from MonitorRASStatusAsync
184			Public Sub detectOnlineOfflineChange()
185	joko	1.6	Dim isOnline As Boolean
186	joko	1.4	Dim script_name As String, script_args As String
187			Dim cmd As String
188
189	joko	1.6	isOnline = RasIsOnline(ConnectionName)
190	joko	1.4
191	joko	1.6	If ConnectionOnline <> isOnline Then
192			'MsgBox isOnline
193	joko	1.4
194	joko	1.6	Select Case ActionType
195
196			Case RUN_SCRIPT:
197			script_name = ScriptName
198			If script_name <> "" Then
199			script_args = Chr(34) & DetermineClientIP(ConnectionName) & Chr(34) & " " & Chr(34) & DetermineServerIP(ConnectionName) & Chr(34)
200			cmd = App.Path & "\" & script_name & " " & script_args
201			End If
202
203			Case ADD_ROUTE:
204			' connection goes online
205			If isOnline = True Then
206			script_name = "route"
207			script_args = "add " & RouteNet & " mask " & RouteMask & " " & DetermineClientIP(ConnectionName)
208			cmd = script_name & " " & script_args
209
210			' connection goes offline
211			Else
212			' Nothing to do in this case
213
214			End If
215
216			End Select
217	joko	1.4
218	joko	1.6	If cmd <> "" Then
219	joko	1.4	'MsgBox cmd
220			On Error Resume Next
221			Shell cmd, vbHide
222	joko	1.7	'Shell cmd, vbNormalFocus
223			'If Err.Number <> 0 Then
224			' MsgBox "Error while calling cmd: " & cmd & vbCrLf & "Error-Number: " & Err.Number
225			'End If
226	joko	1.4	On Error GoTo 0
227			End If
228
229	joko	1.6	ConnectionOnline = isOnline
230	joko	1.8
231			UpdateTrayIcon getTrayIconTipText(ConnectionName, ConnectionOnline)
232
233	joko	1.4	End If
234			End Sub
235	joko	1.8
236			Private Function getTrayIconTipText(conName As String, isOnline As Boolean) As String
237			Dim TipText As String
238			TipText = "VpnDial monitoring """ & conName & """: "
239			If isOnline Then
240			TipText = TipText & "online"
241			Else
242			TipText = TipText & "offline"
243			End If
244			getTrayIconTipText = TipText
245			End Function
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26