xdsl.frm

检测网络中ADSL动态出口IP并与服务器实时更新的程序!

VERSION 5.00
Object = "{18D91AD0-D0BE-11D1-A6B4-00AA002075DA}#1.0#0"; "FlshTray.ocx"
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "shdocvw.dll"
Object = "{8CEFF333-791D-4979-A10C-84C638161B8E}#1.0#0"; "NiceForm.ocx"
Begin VB.Form xDSL 
   BorderStyle     =   1  'Fixed Single
   Caption         =   " Server Info"
   ClientHeight    =   4875
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5445
   Icon            =   "xDSL.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4875
   ScaleWidth      =   5445
   StartUpPosition =   2  '屏幕中心
   Begin NiceFormControl.NiceButton Label4 
      Height          =   375
      Left            =   4440
      TabIndex        =   5
      Top             =   2880
      Width           =   735
      _ExtentX        =   1296
      _ExtentY        =   661
      BTYPE           =   5
      ENAB            =   -1  'True
      BeginProperty FONT {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      COLTYPE         =   1
      FOCUSR          =   -1  'True
      BCOL            =   16777215
      BCOLO           =   16777215
      FCOL            =   0
      FCOLO           =   0
      MCOL            =   12632256
      MPTR            =   1
      MICON           =   "xDSL.frx":030A
      UMCOL           =   -1  'True
      SOFT            =   0   'False
      PICPOS          =   0
      NGREY           =   0   'False
      FX              =   0
      HAND            =   0   'False
      CHECK           =   0   'False
      VALUE           =   0   'False
      Style           =   5
      Caption         =   ">>>"
   End
   Begin VB.TextBox Text2 
      Height          =   375
      Left            =   840
      TabIndex        =   2
      Text            =   "Text2"
      Top             =   4080
      Width           =   2775
   End
   Begin TrayIconPrj.TrayIcon TrayIcon1 
      Left            =   600
      Top             =   1800
      _ExtentX        =   1905
      _ExtentY        =   953
      Icon            =   "xDSL.frx":0326
      ToolTipText     =   "System Tray Icon v.1.0"
      Enabled         =   -1  'True
      TrueClick       =   0   'False
      Visible         =   -1  'True
      FlashSound      =   0
      FlashIcon       =   "xDSL.frx":0640
      FlashInterval   =   1000
      FlashEnabled    =   0   'False
   End
   Begin VB.Timer Timer2 
      Interval        =   10000
      Left            =   1320
      Top             =   600
   End
   Begin SHDocVwCtl.WebBrowser url1 
      Height          =   2385
      Left            =   2400
      TabIndex        =   1
      Top             =   240
      Width           =   2775
      ExtentX         =   4895
      ExtentY         =   4207
      ViewMode        =   0
      Offline         =   0
      Silent          =   0
      RegisterAsBrowser=   0
      RegisterAsDropTarget=   1
      AutoArrange     =   0   'False
      NoClientEdge    =   0   'False
      AlignLeft       =   0   'False
      NoWebView       =   0   'False
      HideFileNames   =   0   'False
      SingleClick     =   0   'False
      SingleSelection =   0   'False
      NoFolders       =   0   'False
      Transparent     =   0   'False
      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
      Location        =   "http:///"
   End
   Begin VB.TextBox Text1 
      Height          =   375
      Left            =   840
      TabIndex        =   0
      Text            =   "Text1"
      Top             =   3480
      Width           =   4335
   End
   Begin NiceFormControl.NiceButton NiceButton1 
      Height          =   375
      Left            =   4080
      TabIndex        =   6
      Top             =   4080
      Width           =   1095
      _ExtentX        =   1931
      _ExtentY        =   661
      BTYPE           =   5
      ENAB            =   -1  'True
      BeginProperty FONT {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      COLTYPE         =   1
      FOCUSR          =   -1  'True
      BCOL            =   16777215
      BCOLO           =   16777215
      FCOL            =   0
      FCOLO           =   0
      MCOL            =   12632256
      MPTR            =   1
      MICON           =   "xDSL.frx":095A
      UMCOL           =   -1  'True
      SOFT            =   0   'False
      PICPOS          =   0
      NGREY           =   0   'False
      FX              =   0
      HAND            =   0   'False
      CHECK           =   0   'False
      VALUE           =   0   'False
      Style           =   5
      Caption         =   "&Updata"
   End
   Begin VB.Label Label3 
      Caption         =   "TIME:"
      Height          =   375
      Left            =   240
      TabIndex        =   4
      Top             =   4170
      Width           =   615
   End
   Begin VB.Label Label2 
      Caption         =   "URL:"
      Height          =   375
      Left            =   240
      TabIndex        =   3
      Top             =   3555
      Width           =   615
   End
   Begin VB.Image Image1 
      BorderStyle     =   1  'Fixed Single
      Height          =   2385
      Left            =   240
      Picture         =   "xDSL.frx":0976
      Top             =   240
      Width           =   2025
   End
End
Attribute VB_Name = "xDSL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
  Dim strCharB, strCharA
  Dim strSectionTemp As String
  Dim strNameTemp As String
  Dim strreturn As String
  
  
  
 Function setProfile(strFileName As String, strSection As String, strName As String, strSave As String) As Boolean
  '这个函数是用来对INI文件进行写操作的
  '函数说明:
  'strFileName 是所要存储的文件名
  'strSection  是这个文件中的一个节点名
  'strName 是所要查找的字段名
  'strSave 是所要替换字段值
  '薛向华 1998/05/13
  
  Dim strTemp As String
  Dim strfileback As String
  Dim strreturn As String
  strfileback = App.Path & "\xDSL.tmp" '临时文件是用来存放中转信息的
  
  Open strFileName For Input As #1
  Open strfileback For Output As #2
   Do While Not EOF(1)
    Line Input #1, strTemp
    strreturn = strTemp
    Print #2, strreturn
    If InStr(1, Trim(strTemp), "[") <> 0 Then
      If InStr(1, Trim(strTemp), Trim(strSection)) <> 0 Then
        Do While Not EOF(1)
            Line Input #1, strTemp
            If InStr(1, Trim(strTemp), Trim(strName)) <> 0 Then Exit Do  '找到所要修改的字段值
            strreturn = strTemp
            Print #2, strreturn  '拷贝不需要的字段值
         Loop
         strreturn = strName & "=" & strSave  '修改
         Print #2, strreturn
      End If
    End If
   Loop
  Close #1
  Close #2
  Open strfileback For Input As #1
  Open strFileName For Output As #2
  Do While Not EOF(1) And EOF(2)
  Line Input #1, strreturn
   Print #2, strreturn
  Loop
  Close #1
  Close #2
End Function
Function GetProfile(strFileName As String, strSection As String, strName As String) As String
  '这个函数是用来对INI文件进行读操作的
  '函数说明:
  'strFileName 是所要读取的文件名
  'strSection  是这个文件中的一个节点名
  'strName 是所要查找的字段名
  '返回值：
  '薛向华 1998/05/13
   strSectionTemp = ""
   strNameTemp = ""
   strreturn = ""
   On Error GoTo ErrSrchSection
   Open strFileName For Input As #1
   ' 下面这段程序是用来查找节点的
     Do While Not EOF(1)
        strCharA = Input(1, #1)
        If strCharA = "[" Then
           Do While Not EOF(1)
             strCharB = Input(1, #1)
             If strCharB = "]" Then Exit Do
             strSectionTemp = strSectionTemp & strCharB
           Loop
        End If
        If strSectionTemp = strSection Then
          strCharA = Input(2, #1)
          Exit Do
        Else
          strSectionTemp = ""
        End If
     Loop
 On Error GoTo ErrReadFile
  
aa:
    '下面这段程序是用来查找所要查找的字段的
    strNameTemp = ""
    Do While Not EOF(1)
      strCharA = Input(1, #1)
      If strCharA <> "=" Then
        strNameTemp = strNameTemp & strCharA  '得到名称
      Else
        Exit Do
      End If
    Loop
        If strNameTemp = strName Then
       Line Input #1, strreturn  '如果找到与它匹配的字段名，就返回得到的值
    Else
       Line Input #1, strreturn  '如果未找到与它匹配的字段名，就继续找
       GoTo aa
    End If
    Close #1
    GetProfile = strreturn
    Exit Function
ErrReadFile:
    Dim inrRet As Integer
    intret = MsgBox("在文件中没有找到所要查找的字段", vbAbortRetryIgnore, "错误信息")
    Select Case intret
       Case vbAbort
          GetProfile = ""
          Close #1
          Exit Function
       Case vbRetry
          Resume
       Case vbIgnore
          Resume Next
     End Select
ErrSrchSection:
     MsgBox "节点未找到", vbOKOnly
     GetProfile = ""
     Close #1
End Function



Private Sub Form_Load()

'读数据
 Dim strPath As String
 strPath = App.Path & "\xDSL.ini"
 Text1 = GetProfile(strPath, "database", "url")
 Text2 = GetProfile(strPath, "database", "time")

'加载网页
 url1.Navigate Text1.Text
 Timer2.Interval = Text2.Text
 xDSL.Height = 3690
End Sub




Private Sub Label4_Click()
If Label4.Caption = ">>>" Then
xDSL.Height = 5100
Label4.Caption = "<<<"
Else
xDSL.Height = 3690
Label4.Caption = ">>>"

End If

End Sub

Private Sub NiceButton1_Click()
If Text2.Text > 60000 Then
MsgBox "输入的值应小于60000,谢谢!", vbInformation
Else
Dim strPath As String
strPath = App.Path & "\xDSL.ini"
setProfile strPath, "database", "url", Text1
setProfile strPath, "database", "time", Text2

url1.Navigate Text1.Text
Timer2.Interval = Text2.Text
End If
End Sub

' 写数据
' Dim strPath As String
' strPath = App.Path & "\xDSL.ini"
' setProfile strPath, "database", "url", Text1
' 读数据
' Dim strPath As String
' strPath = App.Path & "\xDSL.ini"
' Text1 = GetProfile(strPath, "database", "url")

Private Sub Timer2_Timer()
url1.Refresh
End Sub

Private Sub TrayIcon1_LeftButtonClick()
xDSL.Show
End Sub