generalfunc.bas

来电显示客户管理系统 TAPI 应用MSComm控件

Attribute VB_Name = "GeneralFunc"
'声明读写文件API
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

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




'获取应用程序路径
Public Function GetAppPath() As String
    If Right(App.Path, 1) = "\" Then
        GetAppPath = App.Path
    Else
        GetAppPath = App.Path & "\"
    End If
End Function
Public Function WriteOneString(ByVal Section As String, ByVal Key As String, ByVal Value As String, ByVal iniFileName As String) As Boolean
Dim X As Long, buff As String * 128, i As Integer
    buff = Value + Chr(0)
    X = WritePrivateProfileString(Section, Key, buff, iniFileName)
    WriteOneString = X
End Function

Public Function ReadOneString(ByVal Section As String, ByVal Key As String, ByVal iniFileName As String) As String
Dim X As Long, buff As String * 128, i As Integer
    X = GetPrivateProfileString(Section, Key, "", buff, 128, iniFileName)
    i = InStr(buff, Chr(0))
    ReadOneString = Trim(Left(buff, i - 1))
End Function