form1.frm

pppoe创建和加密

        End If
End Function

Public Sub CloseConnected()
Dim lngRetCode As Long
Dim lpcb As Long
Dim lpcConnections As Long
Dim intArraySize As Integer
Dim intLooper As Integer
ReDim lprasconn95(intArraySize) As RASCONN95
lprasconn95(0).dwSize = 412
lpcb = 256 * lprasconn95(0).dwSize
lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)
If lngRetCode = 0 Then
If lpcConnections > 0 Then
For intLooper = 0 To lpcConnections - 1
RasHangUp lprasconn95(intLooper).hRasConn
Next intLooper
Else

End If
End If
End Sub
'检测
Public Function IsConnected() As Boolean    '返回T时为连接
    Dim TRasCon(255) As RASCONN95
    Dim lg As Long
    Dim lpcon As Long
    Dim RetVal As Long
    Dim Tstatus As RASCONNSTATUS95
    '
    TRasCon(0).dwSize = 412
    lg = 256 * TRasCon(0).dwSize
    '
    RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
    If RetVal <> 0 Then
        MsgBox "产生错误！", vbInformation, "提示"
        Exit Function
    End If
    '
    Tstatus.dwSize = 160
    RetVal = RasGetConnectStatus(TRasCon(0).hRasConn, Tstatus)
    If Tstatus.RasConnState = &H2000 Then
        IsConnected = True
    Else
        IsConnected = False
    End If
End Function





Private Sub Check1_Click()
Dim success As Long
If Check1.Value = 1 Then
success = WritePrivateProfileString("server", "auto", "1", f1)
Else
success = WritePrivateProfileString("server", "auto", "0", f1)
End If

End Sub

Private Sub Form_Load()
If App.PrevInstance = True Then
End
End If
Load Form2
acturl = "http://172.30.0.28/www/"
actkey = "pppoe8023"
ll1 = 0
ppzt = 0
pprun = 0
update = 0
activeppoe = 0
On Error Resume Next
f1 = App.Path & "\server.ini"
Call Label11_Click
If Dir(f1) <> "" Then
Dim re As Long
Dim buff As String
buff = String(255, 0)
re = GetPrivateProfileString("server", "key", "0", buff, 256, f1)
Text3 = Trim(buff)
keym = Text3
Text1 = Split(Decrypt(CStr(keym), "lydl.cn"), "|")(0)
Text2 = Split(Decrypt(CStr(keym), "lydl.cn"), "|")(1)
buff = String(255, 0)
re = GetPrivateProfileString("server", "auto", "0", buff, 256, f1)
Text3 = Trim(buff)
Check1.Value = Text3
If Check1.Value = 1 Then
If ppzt = "0" Then
Call Label1_Click
End If
End If
End If
App.TaskVisible = False
 t.cbSize = Len(t)
    t.hwnd = Pic1.hwnd
    t.uId = 1&
    t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    t.ucallbackMessage = WM_MOUSEMOVE
    t.hIcon = Pic1.Picture
    t.szTip = "临沂供电公司接入认证系统" & Chr$(0)
    Shell_NotifyIcon NIM_ADD, t
    
If Dir(f1) = "" Then

 Me.Visible = True
              DoEvents
             
              Me.SetFocus
              Me.Show
              
Exit Sub
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
If Me.Visible = True Then
Cancel = 1
Me.Hide
Else
Shell_NotifyIcon NIM_DELETE, t
Set Form1 = Nothing
End
End If
End Sub

Private Function StripTerminator(sInput As String) As String
    Dim ZeroPos As Integer
    'Search the first chr$(0)
    ZeroPos = InStr(1, sInput, vbNullChar)
    If ZeroPos > 0 Then
        StripTerminator = Left$(sInput, ZeroPos - 1)
    Else
        StripTerminator = sInput
    End If
End Function

Private Sub Label1_Click()

If Label1.Caption = "认证连接" Then
If Trim(Text1) <> "" And Trim(Text2) <> "" Then
Call Create_PPPoE_Connection("LYDLPPPOE", Trim(Text1), Trim(Text2))
'Sleep 1000
Dim success As Long
keym = Encrypt(Text1 & "|" & Text2 & "|", "lydl.cn")
success = WritePrivateProfileString("server", "key", keym, f1)
Me.Hide
a$ = "rasphone.exe   -d   LYDLPPPOE"
Shell a$, vbNormalFocus
SendKeys ("{enter}")

Else
Me.Show
Me.SetFocus
MsgBox "请输入账号姓名及密码！"
End If
Else
Timer1.Enabled = False
Call CloseConnected
Label1.Caption = "认证连接"
Timer1.Enabled = True

End If
End Sub

Private Sub Label11_Click()
kv = ""
Dim hKey As Long, cnt As Long, sSave As String
    'Clear the form
   cnt = 0
    RegOpenKey HKEY_LOCAL_MACHINE, "SOFTWARE", hKey
    Do
        'Create a buffer
        sSave = String(255, 0)
        'Enumerate the keys
        If RegEnumKeyEx(hKey, cnt, sSave, 255, 0, vbNullString, ByVal 0&, ByVal 0&) <> 0 Then Exit Do
        'Print the result to the form
        kv = kv & "," & StripTerminator(sSave)
        cnt = cnt + 1
    Loop
    'Close the registry key
    RegCloseKey hKey
    
    cnt = 0
    RegOpenKey HKEY_LOCAL_MACHINE, "SOFTWARE\microsoft\windows\currentversion\uninstall", hKey
    Do
        'Create a buffer
        sSave = String(255, 0)
        'Enumerate the keys
        If RegEnumKeyEx(hKey, cnt, sSave, 255, 0, vbNullString, ByVal 0&, ByVal 0&) <> 0 Then Exit Do
        'Print the result to the form
        kv = kv & "," & StripTerminator(sSave)
        cnt = cnt + 1
    Loop
    'Close the registry key
    RegCloseKey hKey
    
Text3 = kv
kv1 = ""
If InStr(kv, "金山毒霸") > 0 Then kv1 = kv1 & "金山毒霸 "
If InStr(kv, "McAfee") > 0 Then kv1 = kv1 & "McAfee杀毒软件 "
If InStr(kv, "卡巴基斯") > 0 Then kv1 = kv1 & "卡巴基斯 "
If InStr(kv, "瑞星杀毒软件") > 0 Then kv1 = kv1 & "瑞星杀毒软件 "
If InStr(kv, "江民杀毒") > 0 Then kv1 = kv1 & "江民杀毒 "
If InStr(kv, "Symantec") > 0 Then kv1 = kv1 & "诺顿杀毒软件 "
If InStr(kv, "Virus Chase") > 0 Then kv1 = kv1 & "驱逐舰杀毒软件 "
If InStr(kv, "ESET") > 0 Then kv1 = kv1 & "ESET杀毒软件 "
If InStr(kv, "NOD32") > 0 Then kv1 = kv1 & "NOD32杀毒软件 "

If kv1 <> "" Then
If Len(kv1) > 11 Then
pprun = 0
Label8 = kv1
'MsgBox "请保证计算机中只安装一种杀毒软件，否则将影响防护功能！"
Else
Label8 = kv1
End If
Else
Label8 = "未安装杀毒软件！"
MsgBox "您的计算机未安装杀毒软件，接入将受限！" & Chr(13) & "请在随后打开的页面中选择安装杀毒软件。"
DD = Shell("EXPLOREr.EXE http://home.lydl.cn")
pprun = 0
End If
End Sub

Private Sub Label12_Click()
Text6 = GetUrlFile("http://www.baidu.com/baidu?word=123&tn=ichuner_4_pg&ie=utf-8")

End Sub


Private Sub Label13_Click()
On Error Resume Next
serp = "172.30.0.48"
Text5 = "1"
Text3 = ""
Text3 = GetUrlFile("http://" & serp)
If Split(Text3, "|")(0) <> Label6 And Trim(Text3) <> "" And InStr(Text3, "lypppoe.tmp") <> 0 Then
servername = serp
fz = Split(Split(Text3, "|")(1), ";")
fzsum = UBound(fz)
For mkz = 0 To fzsum
f = App.Path & "\" & fz(mkz)
If fz(mkz) = "" Then Exit For
SetAttr f, vbNormal
Kill f
DoEvents
sourceUrl = "http://" & servername & "/" & fz(mkz)
targetFile = f
    Dim FileList As String
    FileList = sourceUrl & "," & targetFile & "," & "1"
    Call Form2.ShowDownLoad(FileList, Me)
    Sleep 2000
    If Text5 = "0" Then Exit Sub
 Next
 Shell App.Path & "\update.exe"
 Shell_NotifyIcon NIM_DELETE, t
 Set Form1 = Nothing
 End
 Else
 Timer3.Enabled = False
 End If
End Sub



Private Sub Label14_Click()
Call CloseConnected
 
 Shell_NotifyIcon NIM_DELETE, t
 Set Form1 = Nothing
 End
End Sub

Private Sub Label15_Click()
Text6 = GetUrlFile(acturl & "time.php")

End Sub

Private Sub Label16_Click()
On Error Resume Next
password = Replace(Encrypt(Text1 & "," & Text2 & "," & Text6, actkey), "+", ")")
If activeppoe = 0 Then
Text6 = GetUrlFile(acturl & "userinfor.php?userinfo=" & password & "&active=1")
activeppoe = 1
Else
Text6 = GetUrlFile(acturl & "userinfor.php?userinfo=" & password & "&active=0")
End If

If Trim(Text6) <> "" Then
If Split(Trim(Text6), ",")(0) = "-1" Then
Call CloseConnected
End If

If Split(Trim(Text6), ",")(0) = "-2" Then
Call CloseConnected
MsgBox (Split(Trim(Text6), ",")(1))
End If


If Split(Trim(Text6), ",")(0) = "1" Then
Label7(4) = Split(Trim(Text6), ",")(1)
End If


If Split(Trim(Text6), ",")(0) = "2" Then
MsgBox (Split(Trim(Text6), ",")(1))
End If
Else
activeppoe = 0
Text6 = GetUrlFile(acturl & "userinfor.php?userinfo=" & password & "&active=1")
activeppoe = 1
End If
End Sub

Private Sub Label4_Click()
If Me.Check1.Value = 0 Then
Me.Check1.Value = 1
Else
Me.Check1.Value = 0
End If
Dim success As Long
If Check1.Value = 1 Then
success = WritePrivateProfileString("server", "auto", "1", f1)
Else
success = WritePrivateProfileString("server", "auto", "0", f1)
End If


End Sub

Private Sub Pic1_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
Static Rec As Boolean, Msg As Long
On Error Resume Next

    Msg = X / Screen.TwipsPerPixelX
    If Rec = False Then
        Rec = True
        Select Case Msg
            Case WM_LBUTTONDBLCLK:
              Me.Visible = True
              DoEvents
            
              Me.SetFocus
              Me.Show
            Case WM_LBUTTONDOWN:
         
             Me.Visible = True
              DoEvents
            
              Me.SetFocus
              Me.Show
              
            Case WM_LBUTTONUP:
              
            

            Case WM_RBUTTONDBLCLK:
                'PopupMenu mnufile
            Case WM_RBUTTONDOWN:
                
            Case WM_RBUTTONUP:
            
                
        End Select
        Rec = False
    End If


End Sub
Private Function GetUrlFile(stUrl As String) As String
Dim lgInternet As Long, lgSession As Long
Dim stBuf As String * 1024
Dim inRes As Integer
Dim lgRet As Long
Dim stTotal As String
stTotal = vbNullString
lgSession = InternetOpen("VBTagEdit", 1, vbNullString, vbNullString, 0)
If lgSession Then
lgInternet = InternetOpenUrl(lgSession, stUrl, vbNullString, _
0, INTERNET_FLAG_NO_CACHE_WRITE, 0)
If lgInternet Then
Do
inRes = InternetReadFile(lgInternet, stBuf, 1024, lgRet)
stTotal = stTotal & Mid$(stBuf, 1, lgRet)
Loop While (lgRet <> 0)
End If
inRes = InternetCloseHandle(lgInternet)
End If
GetUrlFile = stTotal
End Function

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Text2.SetFocus

End Sub

Private Sub Timer1_Timer()
SetProcessWorkingSetSize GetCurrentProcess(), 50000, 100000
 If IsConnected() = True Then
 ppzt = "1"
 Label1.Caption = "断开连接"
 If Timer2.Enabled = False Then
 Call Label15_Click
 Call Label16_Click
 Timer2.Enabled = True
 End If
  
 Else
 If Timer2.Enabled = True Then
 Timer2.Enabled = False
 End If
 ppzt = "0"
 Label1.Caption = "认证连接"
 End If
End Sub

Private Sub Timer2_Timer()
Call Label11_Click
ll1 = ll1 + 1
If ll1 >= 25 Then
Call Label15_Click
Call Label16_Click
DoEvents
ll1 = 0
End If
End Sub

Private Sub Timer3_Timer()
If ppzt = "1" Then Call Label13_Click
End Sub