flclass.cls

这个就不用多说了

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Flclass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
    Dim myint1 As Integer
    Dim myint2 As Integer
    Dim myint3 As Integer
    Dim myint4 As Integer
    Dim intLong As Integer  '上级长级
    Dim mycommand As New ADODB.Command
    Dim myreder As New ADODB.Recordset
    Dim strTable1 As String
    Dim strTable2 As String
    Sub Tablename(ByVal str1 As String, ByVal str2 As String)
        strTable1 = str1
        strTable2 = str2
    End Sub

    Sub GetCodeMode() '取得编码方式
    sqlconn_open

        Dim strSelect As String
        strSelect = "select * from code where Name = " & "'" & strTable1 & "'"
        mycommand.ActiveConnection = sqlconn
        mycommand.CommandType = adCmdText
        mycommand.CommandText = strSelect
        Set myreder = mycommand.Execute
        myint1 = myreder.Fields(1)
        myint2 = myreder.Fields(2)
        myint3 = myreder.Fields(3)
        myint4 = myreder.Fields(4)

      End Sub
    Function PassTest(ByVal mytext As String) As Boolean '检察字符长度合法性得到上级长度

        PassTest = True
        Dim int1 As Integer
        Dim int2 As Integer
        Dim int3 As Integer
        Dim int4 As Integer
        int1 = myint1
        int2 = int1 + myint2
        int3 = int2 + myint3
        int4 = int3 + myint4
        If Len(mytext) <> int1 And _
  Len(mytext) <> int2 And Len(mytext) <> int3 And Len(mytext) <> int4 Then
            MsgBox "输入位数不正确", vbInformation, "提示"
            PassTest = False
            Exit Function
        Else
            Select Case Len(mytext)
                Case int1
                    intLong = 0
                Case int2
                    intLong = int1
                Case int3
                    intLong = int2
                Case int4
                    intLong = int3
            End Select
        End If
    End Function
    Function PassData(ByVal mystr As String) As Boolean
    On Error GoTo err
    sqlconn_open

        PassData = True
        Dim strSql As String
        If intLong <> 0 Then
            strSql = "select * from " & strTable2 & " where Bm=" & Mid(mystr, 1, intLong)
            mycommand.CommandText = strSql
            mycommand.ActiveConnection = sqlconn
           Set myreder = mycommand.Execute
            If Not myreder.EOF And Not myreder.BOF Then
                
                If strTable1 = "DwBm" Then
                    strSql = "select * from GyzcCare where DwBmId =" & Mid(mystr, 1, intLong)
                End If
                If strTable1 = "Gyzc" Then
                    strSql = "select * from GyzcCare where CodeId =" & Mid(mystr, 1, intLong)
                End If
                mycommand.CommandText = strSql
               Set myreder = mycommand.Execute
                If myreder.EOF Or myreder.BOF Then
                   UpdatRowFlag (Mid(mystr, 1, intLong))
                 
                  '修改末级标志
            Exit Function
                Else
                 
                    PassData = False
                    MsgBox "以有记录不能增加", vbInformation
                    Exit Function
                End If
            Else
           
                PassData = False
                MsgBox "没有上级编码请重输", vbInformation
                Exit Function
            End If

        End If
    
Exit Function
err:
Exit Function
      
      

    End Function

    Sub AddRow(ByVal textbox1 As TextBox, ByVal textbox2 As TextBox)
    On Error GoTo err:
        Dim strinsert As String
        sqlconn_open
        strinsert = "insert into " & strTable2 & " " & "(bm,Name,MjBz) values(" & "'" & textbox1.Text & "'" & "," & "'" & textbox2.Text & "'" & "," & " 1)"
        mycommand.ActiveConnection = sqlconn
        mycommand.CommandType = adCmdText
        mycommand.CommandText = strinsert
      mycommand.Execute
      Exit Sub
err:
MsgBox err.Description, vbInformation, "提示"
    End Sub
    Sub UpdatRowFlag(ByVal str1 As String) '修改末级标志
        Dim strUpdata As String
        strUpdata = "update " & strTable2 & " set MjBz= 0 " & "where Bm= " & str1
        mycommand.ActiveConnection = sqlconn
        mycommand.CommandType = adCmdText
         mycommand.CommandText = strUpdata
        mycommand.Execute
    End Sub
    
    Sub RecoverRowFlag(ByVal str1 As String) '恢复修改末级标志
    

        Dim strSql As String
        If intLong <> 0 Then
            strSql = "select count(*)  from " & strTable2 & " where Bm like " & "'" & Mid(str1, 1, intLong) & "%" & "'"
            sqlconn_open
            mycommand.CommandType = adCmdText
            mycommand.CommandText = strSql
            mycommand.ActiveConnection = sqlconn
          Set myreder = mycommand.Execute
                If myreder.Fields(0) <= 1 Then
               
                strSql = "update " & strTable2 & " set MjBz= 1 " & "where Bm= " & Mid(str1, 1, intLong)
               
                 mycommand.CommandText = strSql
              mycommand.CommandText = strSql

                mycommand.Execute
       
            End If

        End If

    End Sub

    Sub InitialData(ByVal mygrid As MSHFlexGrid)   '初始化
    

        Dim strSql As String
        Call Bt(mygrid)
    
        sqlconn_open
        strSql = "select Bm ,Name ,MjBZ from " & strTable2
        mycommand.ActiveConnection = sqlconn
        mycommand.CommandType = adCmdText
        mycommand.CommandText = strSql
        Set myreder = mycommand.Execute
        If Not myreder.BOF And Not myreder.EOF Then
           While Not myreder.EOF
                mygrid.Rows = mygrid.Rows + 1
                mygrid.Row = mygrid.Rows - 1
                mygrid.col = 0
                mygrid.CellAlignment = 1
                mygrid.Text = myreder.Fields(0)
                mygrid.col = 1
                 mygrid.CellAlignment = 1
                mygrid.Text = myreder.Fields(1)
                mygrid.col = 2
                mygrid.Text = myreder.Fields(2)
                myreder.MoveNext
        
           Wend
       End If

    End Sub
 Sub Bt(ByVal Grid As MSHFlexGrid)

Grid.Row = 0
Grid.col = 0
Grid.CellFontSize = 14
Grid.CellFontBold = True
Grid.CellAlignment = 5
Grid.Text = "编号"
Grid.col = 1
Grid.CellFontSize = 14
Grid.CellAlignment = 5
Grid.CellFontBold = True
Grid.Text = "名称"
Grid.ColWidth(0) = 1500
Grid.ColWidth(1) = 5500
Grid.ColWidth(2) = 0
Grid.Rows = 1
End Sub
    Sub deleterow(ByVal strBm As String, ByVal strfilename As String, str3)



     Dim strSql As String
        mycommand.ActiveConnection = sqlconn
        mycommand.CommandType = adCmdText
        mycommand.CommandText = "select * from GyzcCare where " & strfilename & "=" & strBm
        Set myreder = mycommand.Execute
        If Not myreder.EOF And Not myreder.BOF Then
            MsgBox "以有记录不能再删除", vbInformation
            Exit Sub
        End If
           If PassTest(strBm) Then
               mycommand.CommandText = "delete from " & str3 & "  where Bm = " & strBm
           mycommand.Execute

        End If

    End Sub



    Function UpdataData(ByVal str1 As String, ByVal str2 As String)
On Error GoTo err:
        Dim strUpdata As String
        strUpdata = "update " & strTable2 & " " & "set bm=" & "'" & str1 & "'" & ",Name=" & "'" & str2 & "'" & " where Bm= " & str1
        sqlconn_open
        mycommand.ActiveConnection = sqlconn
        mycommand.CommandType = adCmdText
        mycommand.CommandText = strUpdata
        mycommand.Execute

err:
 Exit Function
    End Function