frmmain.frm

设置IP地址工具

                strProfileValues = strProfileValues & arrValues(j) & "|"
            Else
                strProfileValues = strProfileValues & arrValues(j) & "."
            End If
        Next j
        If sKey(i) <> "" Then
            Call addListValues(strProfileValues, sProfile)
        End If
    Next i

End Sub


Public Sub addListValues(strValues As String, strCurrProfile As String)
    Dim i As Long
    Dim addlist As ListItem
    Dim arrValues() As String
    
    arrValues = Split(strValues, "|")
    
    With LVIP
        Set addlist = .ListItems.Add()
        ' 先将空值写入subitem中
        For i = 0 To .ColumnHeaders.Count - 2
            addlist.SubItems(i + 1) = ""
        Next i
        
        For i = 0 To UBound(arrValues) - 1
            If arrValues(0) = strCurrProfile Then
               '.ListItems.Item(1).Checked = True
               addlist.Checked = True
            End If
            addlist.SubItems(i + 1) = arrValues(i)
        Next i
    End With
      
End Sub

Private Sub LVIP_Click()
    
    SBState.Panels(3).Text = LVIP.SelectedItem.ListSubItems(2)
End Sub

Private Sub LVIP_DblClick()
    
    MenuEdit_Click
    
End Sub

Private Sub MenuAdd_Click()
    
    Dim frmIP  As New FrmIpManage
    
    On Error GoTo ErrMsg
    eProfileMode = PROF_MODE_NEW
    frmIP.Show vbModal
    
    If frmIP.IsExit = False Then
        Call InitProfiles
    End If
    
    Set frmIP = Nothing
    
    Exit Sub
ErrMsg:
    MsgBox Err.Description, vbCritical, HINT

End Sub

Private Sub MenuDelete_Click()
    
    Call CIni.DeleteKey(INI_SECTION_PROFILES, LVIP.SelectedItem.ListSubItems(1).Text)
     Call InitProfiles
'    lvip.ListItems(LVIP.SelectedItem.Index).
'    Call LVIP.SelectedItem.Index
End Sub

Private Sub menuDiaplasis_Click()
    
    On Error GoTo ErrMsg
    Screen.MousePointer = vbHourglass
    Call SetTCP_Automatic
    SBState.Panels(4).Text = "复位成功"
    Screen.MousePointer = vbNormal
    Exit Sub
ErrMsg:
    Screen.MousePointer = vbNormal
    MsgBox Err.Description, vbInformation, HINT
    
End Sub

Private Sub MenuEdit_Click()
    
    Dim frmIP           As New FrmIpManage
    Dim i%
    Dim strIPValues     As String
    Dim strValues()     As String
    
    On Error GoTo ErrMsg
    eProfileMode = PROF_MODE_EDIT
    
    With LVIP
        If .ListItems.Count = 0 Then Exit Sub
    
        For i = 1 To .SelectedItem.ListSubItems.Count
            If i = 1 Then
                strIPValues = .SelectedItem.ListSubItems(i).Text
            Else
                strIPValues = strIPValues & "." & .SelectedItem.ListSubItems(i).Text
            End If
        Next i
    End With
    
    strValues = Split(strIPValues, ".")
    If UBound(strValues) <= 0 Then Exit Sub
    frmIP.txtProfileName.Text = strValues(0)
    frmIP.m_CurrProfile = strValues(0)
    For i = 1 To UBound(strValues) - 1
        frmIP.txtIP(i - 1).Text = strValues(i)
    Next i
    
    frmIP.Show vbModal
    If frmIP.IsExit = False Then
        Call InitProfiles
    End If
    
    Set frmIP = Nothing
    Exit Sub
ErrMsg:
    MsgBox Err.Description, vbInformation, HINT

End Sub

Private Sub menuexit_Click()
    
    Unload Me
    
End Sub

Private Sub menuping_Click()
    
    Dim mmp As New clsNet
    Dim strHint As String
    
    On Error GoTo ErrMsg
    SBState.Panels(4).Text = ""
    LVIP.SelectedItem.ListSubItems(7).Text = ""
    If mmp.Ping(LVIP.SelectedItem.ListSubItems(2).Text) Then
        
        strHint = "成功"
    Else
        strHint = "失败"
    End If
    SBState.Panels(4).Text = strHint
    LVIP.SelectedItem.ListSubItems(7).Text = strHint
    Exit Sub
ErrMsg:
    SBState.Panels(4).Text = "失败"
    LVIP.SelectedItem.ListSubItems(7).Text = strHint
    MsgBox Err.Description, vbCritical, HINT
    
End Sub

Private Sub menuSendIP_Click()

    On Error GoTo ErrMsg
    If EachNIC = False Then Exit Sub
  
    CIni.WriteString "CurrentProfile", "ProfileName", LVIP.SelectedItem.ListSubItems(1)
  
    Dim sProfile As String
    sProfile = CIni.GetIniString("CurrentProfile", "ProfileName", "")
    Me.Caption = App.ProductName & IIf(sProfile <> "", " (" & sProfile & ")", "")
    SetCurrList
    
    SBState.Panels(4).Text = "激活成功"
    Exit Sub
ErrMsg:
    SBState.Panels(4).Text = "激活失败"
    MsgBox Err.Description, vbCritical, HINT

End Sub

Private Sub SetCurrList()
    
    Dim i%
    
    
    With LVIP
        For i = 1 To .ListItems.Count
            .ListItems.Item(i).Checked = False
        Next i
        .SelectedItem.Checked = True
    End With
    
End Sub

Private Sub TbMenu_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    Select Case Button.Caption
    Case "编辑实例"
        MenuEdit_Click
    Case "添加实例"
        MenuAdd_Click
    Case "删除实例"
        MenuDelete_Click
    Case "激活IP"
        menuSendIP_Click
    Case "Ping"
        menuping_Click
    Case "复位"
        menuDiaplasis_Click
    Case "退出"
        menuexit_Click
    End Select
    
End Sub


'复位
Private Function SetTCP_Automatic() As Long
'**************************************************************
'     SetDHCP.vbs
'**************************************************************
Dim wmiLocator As Object
Dim wmiService As Object
Dim colNetAdapters As Object
Dim objNetAdapter As Object
Dim strIPAddress As Variant
Dim strSubnetMask As Variant
Dim strGateway As Variant
Dim strGatewayMetric As Variant
Dim strDNSServers As Variant
Dim errEnable As Variant
Dim errGateways As Variant
Dim errDNSServers As Variant

Dim sMsg As String


  SetTCP_Automatic = DHCP_CANCEL
  
  Set wmiLocator = CreateObject("WbemScripting.SWbemLocator")
  Set wmiService = wmiLocator.ConnectServer("localhost", "root\cimv2")
  wmiService.Security_.ImpersonationLevel = 3
  
  Set colNetAdapters = wmiService.ExecQuery _
  ("Select * from Win32_NetworkAdapterConfiguration where IPEnabled=TRUE")
  
  On Error Resume Next
  
  For Each objNetAdapter In colNetAdapters
    errDNSServers = objNetAdapter.SetDNSServerSearchOrder()
    errEnable = objNetAdapter.EnableDHCP()
    If errEnable = 0 Then
      SetTCP_Automatic = DHCP_ENABLED       'DHCP has been enabled.
    Else
      SetTCP_Automatic = DHCP_NOT_ENABLED   'DHCP could not be enabled.
    End If
  Next

End Function

Public Sub SetTCP_Profile(NetworkCards As String)
  
  sComputer = "."  ' Computer Name (.) for local computer
    
  Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
  Set cNetAdapters = oWMIService.ExecQuery("Select * FROM Win32_NetworkAdapterConfiguration where IPEnabled=TRUE")


  With LVIP
    sIPAddress = Array(.SelectedItem.ListSubItems(2).Text)    'Array(RetAddr(sAr(), 0))
    sSubnetMask = Array(.SelectedItem.ListSubItems(3).Text) 'Array(RetAddr(sAr(), 4))
    sGateway = Array(.SelectedItem.ListSubItems(4).Text) 'Array(RetAddr(sAr(), 8))
    sGatewaymetric = Array(1)
    sDNSServers = Array(.SelectedItem.ListSubItems(5).Text, .SelectedItem.ListSubItems(6).Text)
  End With
  sWINSPriServer = "0.0.0.0"
  sWINSSecServer = "0.0.0.0"

  
  For Each oNetAdapter In cNetAdapters
      Rem If NetWorkCard = *ALL the profile will activated
      If InStr(1, oNetAdapter.Caption, NetworkCards) > 0 Or NetworkCards = "*ALL" Then
            bErr = oNetAdapter.EnableStatic(sIPAddress, sSubnetMask)
            bErr = oNetAdapter.SetGateways(sGateway, sGatewaymetric)
            bErr = oNetAdapter.SetDNSServerSearchOrder(sDNSServers)
            bErr = oNetAdapter.SetWINSServer(sWINSPriServer, sWINSSecServer)
      End If
  Next

End Sub


Private Function EachNIC() As Boolean
    Dim frmNIC As frmSelectNIC
    Dim NetWorkCard As String
    
    EachNIC = False
    
    Set frmNIC = New frmSelectNIC
    Load frmNIC
    
    frmNIC.Show vbModal, Me
    
    Screen.MousePointer = vbHourglass

    DoEvents
    NetWorkCard = frmNIC.SelectedNIC
    
    Set frmNIC = Nothing
    
    If Trim$(NetWorkCard & "") = "" Then Exit Function
       
        If SetTCP_Automatic() = DHCP_ENABLED Then   ' False=no message
          SetTCP_Profile NetWorkCard
        End If
  
    EachNIC = True
    Screen.MousePointer = vbNormal
End Function

Public Function RetAddr(ByRef ar As Variant, idx As Integer) As String
  
  Dim k As Integer, sTmp As String
  
  For k = idx To idx + 3
    Rem Format the stringa, add the dot (.)
    sTmp = sTmp & "." & ar(k)
  Next k
  
  Rem Return address, first dot is removed.
  RetAddr = Mid(sTmp, 2)
  
End Function