Attribute VB_Name = "Control"

'vb获取本机所有ip地址

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetIpAddrTable Lib "IPHlpApi" (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long

Private Const MAX_IP = 255

Private Type IPINFO
    dwAddr As Long              'Ip地址
    dwIndex As Long
    dwMask  As Long             '子网掩码
    dwBCastAddr As Long         '广播地址
    dwReasmSize As Long
    unused1 As Integer
    unused2 As Integer
End Type

Private Type MIB_IPADDRTABLE
    dEntrys As Long
    mIPInfo(MAX_IP) As IPINFO
End Type

Private Type IP_Array
    mBuffer As MIB_IPADDRTABLE
    BufferLen As Long
End Type

Private Declare Sub Sleep Lib "kernel32" (ByVal dwmillseconds As Long)  '延时用API库函数

Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Const CB_SETDROPPEDWIDTH = &H160
Private Const CB_ERR = -1

' 取得 Combo 下拉的宽度
' 可以利用该函数比例放大或缩小宽度
Function GetDropdownWidth(cboHwnd As Long) As Long
    Dim lRetVal As Long
    lRetVal = SendMessage(cboHwnd, CB_GETDROPPEDWIDTH, 0, 0)
    If lRetVal <> CB_ERR Then
        GetDropdownWidth = lRetVal
        '单位为 pixels
    Else
        GetDropdownWidth = 0
    End If
End Function
'设置 Combo 下拉的宽度
'单位为 pixels
Function SetDropdownWidth(cboHwnd As Long, NewWidthPixel As Long) As Boolean
    Dim lRetVal As Long
    lRetVal = SendMessage(cboHwnd, CB_SETDROPPEDWIDTH, NewWidthPixel, 0)
    If lRetVal <> CB_ERR Then
        SetDropdownWidth = True
    Else
        SetDropdownWidth = False
    End If
End Function

Sub SetWidth_ComboBox(ByVal c As ComboBox, ByVal Rat As Single)
    'SetDropdownWidth c.hwnd, GetDropdownWidth(c.hwnd) * Rat
    SetDropdownWidth c.hwnd, 121 * Rat
End Sub


Public Sub DelayTime(millseconds As Long)
    Sleep (millseconds)
    DoEvents
End Sub

Function MaxLen(ByVal c As ComboBox) As Integer
    Dim temp As Integer, temp1 As Integer
    With c
        For i = 0 To .ListCount - 1
            temp1 = Len(Trim$(.List(i)))
            temp = IIf(temp > temp1, temp, temp1)
        Next i
    End With
    MaxLen = temp
End Function

Function GetIPAddress() As String
    Dim Ret As Long, Tel As Long
    Dim bBytes() As Byte
    Dim Listing As MIB_IPADDRTABLE
    GetIpAddrTable ByVal 0&, Ret, True
    If Ret <= 0 Then Exit Function
    ReDim bBytes(0 To Ret - 1) As Byte
    GetIpAddrTable bBytes(0), Ret, False
    CopyMemory Listing.dEntrys, bBytes(0), 4
    CopyMemory Listing.mIPInfo(Tel), bBytes(4), Len(Listing.mIPInfo(0))
    GetIPAddress = ConvertAddressToString(Listing.mIPInfo(0).dwAddr)
End Function
Private Function ConvertAddressToString(longAddr As Long) As String
    Dim myByte(3) As Byte
    Dim Cnt As Long
    CopyMemory myByte(0), longAddr, 4
    For Cnt = 0 To 3
        ConvertAddressToString = ConvertAddressToString + CStr(myByte(Cnt)) + "."
    Next Cnt
    ConvertAddressToString = Left$(ConvertAddressToString, Len(ConvertAddressToString) - 1)
End Function

Function OpenFile() As String                    '打开对话框,并初始化Ini变量

    Dim MyDialog As New CommonDialog
    MyDialog.Filter = "Ini文件（*.ini）| *.ini| "   '文件类型过滤
    MyDialog.ShowOpen
    
    OpenFile = MyDialog.FileName                        '给模块变量赋值
    
End Function

Sub CreateAfile(ByVal FilePath As String)
On Error GoTo ErrHandle
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(FilePath, True)
    a.Close
ErrHandle:
End Sub

Sub IniComboText(ByVal Combo As ComboBox, ByVal Arr As Variant)     '初始化Combo内容
    With Combo
        .Clear
        For i = 0 To UBound(Arr)
            .AddItem Arr(i)
            .ListIndex = 0
        Next i
    End With
End Sub

Sub IniTabsText(ByVal Tabs As TabStrip, ByVal Arr As Variant)       '初始化TabStrip内容
    With Tabs
        .Tabs.Clear
        For i = 0 To UBound(Arr)
            .Tabs.Add "", Arr(i), 0
        Next i
    End With
End Sub

Sub Change_TabName(ByVal T As TabStrip, ByVal Index As Integer, ByVal Name As String)       'TabStrip的Tabs(Index)名称为Name
    With T.Tabs
        .Remove (Index)
        .Add "", Name, 0
    End With
End Sub

Sub Select_Tabs(ByVal T As TabStrip, ByVal Index As Integer)        '选中Tabs
    With T
        .Value = Index
    End With
End Sub

Sub IniListView(ByVal Lvw As ListView)
    With Lvw
        .ListItems.Clear               '清空列表
        .ColumnHeaders.Clear           '清空列表头
        .View = lvwReport              '设置列表显示方式
        .GridLines = True              '显示网络线
        .LabelEdit = lvwManual         '禁止标签编辑
        .FullRowSelect = True          '选择整行
        .View = lvwReport              '设置显示方式为列表
        .AllowColumnReorder = True     '对行进行程序排列，用鼠标进行排列
        .Arrange = lvwAutoLeft         '图标横排列
        .Arrange = lvwAutoTop          '图标竖排列
        .FlatScrollBar = False         '显示滚动条
        .FlatScrollBar = True          '隐藏滚动条
        .FullRowSelect = True          '选择整行
        .LabelEdit = lvwManual         '禁止标签编辑
        .GridLines = True              '显示网络线
        .LabelWrap = True              '图标可以换行
        .MultiSelect = True            '可以选择多个项目
        .PictureAlignment = lvwTopLeft '图片对齐方式是左顶部，其他有右顶部(1)、左底部(2)、右底部(3)、居中(4)、平铺(5)
        .Checkboxes = True             '显示复选框
        '.DropHighlight = .ListItems.Item(2)   '显示系统颜色
        .Checkboxes = False
               
        '.ListItems.Add , , "复位/状态"
    End With
End Sub

Function CheckText(ByVal Frm As Form, ByVal ContainerName As String, ByVal ControlName As String) As Boolean       '检查是否存在未编辑信息

    CheckText = True    '初始化,置True
    
    Dim obj As Object   'Fram3中TextBox存在空,置False
    For Each obj In Frm.Controls
        If obj.Container.Name = ContainerName And TypeName(obj) = ControlName Then
            If obj.Text = "" Then
                CheckText = False
                Exit For
            End If
        End If
    Next
    
    Exit Function
    MsgBox "输入不完整!", vbCritical, "添加错误"
    
End Function

Sub ClearText(ByVal Frm As Form, ByVal ContainerName As String, ByVal ControlName As String)
    Dim obj As Object                                   '清除Fram3中TextBox内容
    For Each obj In Frm.Controls
        If obj.Container.Name = ContainerName And TypeName(obj) = ControlName Then
            obj.Text = ""
        End If
    Next
End Sub

Sub DeletSelectRow(ByVal Lvw As ListView)
    With Lvw
        If .ListItems.Count = 0 Then Exit Sub           '判断Lvw是否存在内容
        For i = .SelectedItem.Index To .ListItems.Count
            .ListItems(i).SubItems(1) = i - 1           '更新序号
        Next i
        .ListItems.Remove (.SelectedItem.Index)         '删除Lvw选定行
    End With
End Sub

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub Add_Header(ByVal Lvw As ListView, ByVal HeaderName As Variant, ByVal HeaderWidth As Variant, ByVal FontName As String, ByVal FontSize As Integer, ByVal FontBold As Boolean, ByVal ForeCol As ColorConstants, ByVal BackCol As ColorConstants, ByVal ScrollBar As Boolean)
    IniListView Lvw
    With Lvw
        For i = LBound(HeaderName) To UBound(HeaderName)
            .ColumnHeaders.Add , , HeaderName(i), HeaderWidth(i)    '列头名称、宽度
        Next i
        For i = LBound(HeaderName) + 2 To UBound(HeaderName) + 1
            .ColumnHeaders(i).Alignment = lvwColumnCenter           '文本居中
        Next i
        .Font.Name = FontName                                       '字体
        .Font.Size = FontSize                                       '字体大小
        .Font.Bold = FontBold                                       '字体是否加粗
        .ForeColor = ForeCol                                        '字体颜色
        .BackColor = BackCol                                        '背景颜色
        .FlatScrollBar = ScrollBar                                  '滚动条是否显示
    End With
End Sub

Sub Add_List(ByVal Frm As Form, ByVal Lvw As ListView, ByVal StartTabIndex As Integer, ByVal EndTabIndex As Integer)
On Error GoTo Err
    With Lvw
        .ListItems.Add
        .ListItems(.ListItems.Count).SubItems(1) = .ListItems.Count
        .ListItems(.ListItems.Count).ListSubItems(1).ForeColor = vbBlack
        Dim obj As Object
        Dim i As Integer
        For i = StartTabIndex To EndTabIndex
            For Each obj In Frm.Controls
                If TypeName(obj) <> "Shape" Then
                    If obj.TabIndex = i Then
                        If obj.Text = "" Then
                            'MsgBox "输入有误！", vbCritical, "配置参数"
                            .ListItems.Remove (.ListItems.Count)         '删除Lvw选定行
                            Exit Sub
                        End If
                        .ListItems(.ListItems.Count).SubItems(i + 1) = obj.Text
                    End If
                End If
            Next
        Next i
    End With
Err:
End Sub

Sub Verify_List(ByVal Frm As Form, ByVal Lvw As ListView, ByVal StartTabIndex As Integer, ByVal EndTabIndex As Integer)
On Error GoTo Err
    With Lvw
        Dim obj As Object
        Dim i As Integer, RowIndex As Integer
        RowIndex = .SelectedItem.Index
        For i = StartTabIndex To EndTabIndex
            For Each obj In Frm.Controls
                If TypeName(obj) <> "Shape" Then
                    If obj.TabIndex = i Then
                        If obj.Text = "" Then
                            'MsgBox "输入有误！", vbCritical, "配置参数"
                            Exit Sub
                        End If
                        .ListItems(RowIndex).SubItems(i + 1) = obj.Text
                    End If
                End If
            Next
        Next i
    End With
Err:
End Sub

Sub Delet_Row(ByVal Lvw As ListView, ByVal RowIndex As Integer)      '删除指定行
On Error GoTo Err
    With Lvw
        If .ListItems.Count = 0 Then Exit Sub                       '判断Lvw是否存在内容
        For i = RowIndex To .ListItems.Count
            .ListItems(i).SubItems(1) = i - 1                       '更新序号
        Next i
        .ListItems.Remove (RowIndex)                                '删除Lvw指定行
    End With
Err:
End Sub

Function Dialog_Name(ByVal ActionIndex As Integer, ByVal Filter As String) As String
    Dim MyDialog As New CommonDialog
    'MyDialog.Filter = "Ini文件（*.ini）| *.ini| "                  '文件类型过滤
    MyDialog.Filter = Filter                                        '文件类型过滤
    MyDialog.Action = ActionIndex
    Dialog_Name = MyDialog.FileName                                 '给模块变量赋值
End Function