generalfunc.bas

这是一个利用VB编写的中小企业ERP。功能比较全

Attribute VB_Name = "GeneralFunc"

Public Sub Add_DepToTree(TreeView1 As TreeView, _
                         ByVal TmpKey As String)
    Dim Bh As Long
    Dim TmpNode As Node
    '当前选择结点的关键字
    Dim CurKey As String
    '临时数组
    Dim TmpArr_DepName() As String
    Dim TmpArr_DepId() As Long
    ReDim TmpArr_DepName(0)
    ReDim TmpArr_DepId(0)
    '从关键字中读取当前的部门编号
    Bh = Val(Right(TmpKey, Len(TmpKey) - 1))
    '获取当前部门信息
    MyDep.GetInfo (Bh)
    '读取当前部门的下一级部门数据
    MyDep.Load_Department_ByUpper (Bh)
    '将下一级部门数据赋值到临时数组中
    i = 0
    Do While Arr_DepName(i) <> ""
        ReDim Preserve TmpArr_DepName(i + 1)
        TmpArr_DepName(i) = Arr_DepName(i)
        ReDim Preserve TmpArr_DepId(i + 1)
        TmpArr_DepId(i) = Arr_DepId(i)
        i = i + 1
    Loop
    
    i = 0
    Do While TmpArr_DepName(i) <> ""
        '生成部门对应的关键字，格式为“字母a”＋部门编号
        CurKey = "a" + Trim(Str(TmpArr_DepId(i)))
        '如果当前部门有下一级部门,则显示文件夹图标
        If MyDep.HaveSon(TmpArr_DepId(i)) = True Then
            Set TmpNode = TreeView1.Nodes.Add(TmpKey, _
                          tvwChild, CurKey, TmpArr_DepName(i), 1, 3)
            
            TmpNode.ExpandedImage = 2
            '否则显示叶结点图标
        Else
            Set TmpNode = TreeView1.Nodes.Add(TmpKey, _
                          tvwChild, CurKey, TmpArr_DepName(i), 4, 5)
        End If
        'FocusDepName、FocusDepBh和FocusDepKey分别表示希望选中的部门的名称、编号和关键字
        If FocusDepName <> "" And TmpArr_DepName(i) = FocusDepName Then
            TmpNode.Selected = True
            FocusDepKey = CurKey
        End If
        If FocusDepBh > 0 And TmpArr_DepId(i) = FocusDepBh Then
            TmpNode.Selected = True
            FocusDepKey = CurKey
        End If
        If FocusDepKey <> "" And CurKey = FocusDepKey Then
            TmpNode.Selected = True
        End If
        '以当前部门为参数递归调用
        Call Add_DepToTree(TreeView1, CurKey)
        i = i + 1
    Loop
End Sub

Public Function In_Single(KeyAscii As Integer) As Boolean
    Dim Ch_Accept_Single(20) As String
    '可以接受的字符数组
    Ch_Accept_Single(0) = "0"
    Ch_Accept_Single(1) = "1"
    Ch_Accept_Single(2) = "2"
    Ch_Accept_Single(3) = "3"
    Ch_Accept_Single(4) = "4"
    Ch_Accept_Single(5) = "5"
    Ch_Accept_Single(6) = "6"
    Ch_Accept_Single(7) = "7"
    Ch_Accept_Single(8) = "8"
    Ch_Accept_Single(9) = "9"
    Ch_Accept_Single(10) = "."
    Ch_Accept_Single(11) = "-"
    Ch_Accept_Single(12) = Chr(8)
    '检查输入字符是否在数组中
    In_Single = False
    For i = 0 To 12
        If Chr(KeyAscii) = Ch_Accept_Single(i) Then
            In_Single = True
        End If
    Next
End Function

Public Function In_Int(KeyAscii As Integer) As Boolean
    Dim Ch_Accept_Int(20) As String
    '可以接受的字符数组
    Ch_Accept_Int(0) = "0"
    Ch_Accept_Int(1) = "1"
    Ch_Accept_Int(2) = "2"
    Ch_Accept_Int(3) = "3"
    Ch_Accept_Int(4) = "4"
    Ch_Accept_Int(5) = "5"
    Ch_Accept_Int(6) = "6"
    Ch_Accept_Int(7) = "7"
    Ch_Accept_Int(8) = "8"
    Ch_Accept_Int(9) = "9"
    Ch_Accept_Int(10) = Chr(8)
    '检查输入字符是否在数组中
    In_Int = False
    For i = 0 To 10
        If Chr(KeyAscii) = Ch_Accept_Int(i) Then
            In_Int = True
        End If
    Next
End Function

Public Function InCombo(ByVal Str As String, _
                        ByVal Combo1 As ComboBox) As Boolean
    i = 0
    Do While i < Combo1.ListCount
        If Combo1.List(i) = Trim(Str) Then
            InCombo = True
            Exit Function
        End If
        i = i + 1
    Loop
    MsgBox Str + " 不在列表中，请重新设置"
    InCombo = False
End Function

Public Function Lench(ByVal TmpStr As String) As String
    Lench = LenB(StrConv(TmpStr, vbFromUnicode))
End Function

Public Function TrimStr(ByVal Str As String) As String
    If InStr(Str, Chr(0)) <= 0 Then
        TrimStr = Trim(Str)
    Else
        TrimStr = Trim(Left(Str, InStr(Str, Chr(0)) - 1))
    End If
End Function

Public Function MakeStr(ByVal Str As String) As String
    MakeStr = Trim(Replace(Str, "'", "''"))
End Function

Public Sub EnterTAB(KeyAscii As Integer)
    If KeyAscii = 13 Then '13表示回车键
        SendKeys "{TAB}" '转换为TAB键
    End If
End Sub