modpublicfunction.bas

企业ERP系统 采用VB+SQL2000实现。 有客户合约

    End If
    If cha > 5000 And cha <= 20000 Then
        output = cha * 0.2 - 375
    End If
    If cha > 20000 And cha <= 40000 Then
        output = cha * 0.25 - 1375
    End If
    If cha > 40000 And cha <= 60000 Then
        output = cha * 0.3 - 3375
    End If
    If cha > 60000 And cha <= 80000 Then
        output = cha * 0.35 - 6375
    End If
    If cha > 80000 And cha <= 100000 Then
        output = cha * 0.4 - 10375
    End If
    If cha > 100000 And cha > 100000 Then
        output = cha * 0.45 - 15375
    End If
    IndividualTax = output
End Function


'重新读取一下远程的地址
Public Function ReadServerName() As String
    If objDatabase.GetEnterMode = False Then
        Dim strServerName As String
        strServerName = ResponseAddress(objDatabase.GetAddress1 & "?id=1")
        ReadServerName = Replace(strServerName, vbNullChar, "")
    End If
End Function


'返回ID号
Public Function GetRecordNo(strTable As String, strId As String) As String
    Dim strSql As String
    Dim lngID As Long
    Dim rs As ADODB.Recordset
    
   ' strSql = "select * from " & strTable & ""
    Set rs = New ADODB.Recordset
    On Error GoTo errHandle
    With rs
        .LockType = adLockOptimistic
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        Set .ActiveConnection = Cn
    End With
    'rs.Open strSql
    'If Not rs.EOF Then
     '   rs.Close
        strSql = "select isnull(max(" & strId & "),0) as ID from " & strTable
        rs.Open strSql
        'If rs.EOF Or rs.BOF Then
        '    GetRecordNo = 1
        'Else
            lngID = Val(rs.Fields!ID)
            lngID = Abs(lngID) + 1
            GetRecordNo = lngID
            
           
       ' End If
    rs.Close
    Set rs = Nothing
    Exit Function
errHandle:
   Set rs = Nothing
   objDatabase.DatabaseError
End Function
'初始comboBox控件内容
Public Sub Initcbb(ComboCustomer As ComboBox, item As String, table As String)
    Dim rs As ADODB.Recordset
    On Error GoTo errLabel
    Set rs = New ADODB.Recordset
    With rs
      .CursorLocation = adUseClient
      .CursorType = adOpenDynamic
      .LockType = adLockOptimistic
      Set .ActiveConnection = Cn
    End With
    rs.Open "select " & item & " from " & table
    
    On Error Resume Next
    ComboCustomer.Text = ""
    Do While Not rs.EOF
       ComboCustomer.AddItem rs(0)
       rs.MoveNext
    Loop
    rs.Close
remClear:
    Set rs = Nothing
    Exit Sub
errLabel:
    GoTo remClear
    objDatabase.DatabaseError
    
End Sub
'返回指定值
Public Function ReturnValue(item As String, table) As Variant
    Dim rs As ADODB.Recordset
    On Error GoTo errLabel
    Set rs = New ADODB.Recordset
    With rs
      .CursorLocation = adUseClient
      .CursorType = adOpenDynamic
      .LockType = adLockOptimistic
      Set .ActiveConnection = Cn
    End With
    rs.Open "select " & item & " as returnvalue from " & table
    
    If Not rs.EOF Then
        ReturnValue = NullValue(rs.Fields!ReturnValue) '有
    Else
        ReturnValue = "" '没有
    End If
    rs.Close
remClear:
    Set rs = Nothing
    Exit Function
errLabel:
    GoTo remClear
    objDatabase.DatabaseError
End Function


'返回是否有相同的值
Public Function ReturnRepeat(item As String, table As String) As Boolean
    Dim rs As ADODB.Recordset
    On Error GoTo errLabel
    Set rs = New ADODB.Recordset
    With rs
      .CursorLocation = adUseClient
      .CursorType = adOpenDynamic
      .LockType = adLockOptimistic
      Set .ActiveConnection = Cn
    End With
    rs.Open "select " & item & " from " & table
    
    If Not rs.EOF Then
        ReturnRepeat = True '有重复
    Else
        ReturnRepeat = False '无重复
    End If
    rs.Close
remClear:
    Set rs = Nothing
    Exit Function
errLabel:
    GoTo remClear
    objDatabase.DatabaseError
End Function

'设置时间格式
Public Function GetCurTime() As Date
    GetCurTime = Format(Now, "yyyy-MM-dd hh:mm:ss")
End Function
'设置时间格式
Public Function GetCurDate() As Date
    GetCurDate = Format(Date, "yyyy-MM-dd")
End Function

'"   将图片转换成字节数组
Public Function PictureToBin(Picture As StdPicture) As Byte()
        
        Dim oPB As PropertyBag
        
        Set oPB = New PropertyBag
        oPB.WriteProperty "P", Picture, Nothing
        PictureToBin = oPB.Contents
        Set oPB = Nothing
        
End Function

'"   从字节数组还原图片
Public Function BinToPicture(data() As Byte) As StdPicture
        
        Dim oPB As PropertyBag
        
        Set oPB = New PropertyBag
        oPB.Contents = data()
        Set BinToPicture = oPB.ReadProperty("P", Nothing)
        Set oPB = Nothing
        
End Function
'检查消息
Public Sub CheckMessage()
    Dim rs As ADODB.Recordset
      'SystemExecuteStart Me
      On Error GoTo errHandle
      Set rs = New ADODB.Recordset
      With rs
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        Set .ActiveConnection = Cn
      End With
      Dim strSql As String
      strSql = "select * from tMessageView where IsView=0 and Operator=" & objDatabase.FormatSQL(userInf.userName) & " order by RecordNO desc"
      rs.Open strSql
        If Not rs.EOF Then
'            frmMessageInfo.recordNo = NullValue(rs.Fields!recordNo)
'           frmMessageInfo.newMessage = False
'           frmMessageInfo.popForm = True
'           'frmMessageInfo.StartUpPosition = 0
'           frmMessageInfo.Show
        End If
      rs.Close
      Set rs = Nothing
      'SystemExecuteEnd Me
    
Exit Sub
errHandle:
    Set rs = Nothing
    
    objDatabase.DatabaseError
End Sub
Public Function bRole(strRoleItem As String) As Boolean
bRole = False
Dim rs As ADODB.Recordset
    On Error GoTo errLabel
    Set rs = New ADODB.Recordset
    With rs
      .CursorLocation = adUseClient
      .CursorType = adOpenDynamic
      .LockType = adLockOptimistic
      Set .ActiveConnection = Cn
    End With
    rs.Open "select " & strRoleItem & " from trole where Operator=" & objDatabase.FormatSQL(userInf.userName)
    
    On Error Resume Next
    If userInf.userID = "1" Then
        bRole = True
    Else
        If rs.RecordCount > 0 Then
            If rs(0) = 1 Then
                bRole = True
            Else
                bRole = False
            End If
        Else
            bRole = False
        End If
    End If
    rs.Close
remClear:
    Set rs = Nothing
    Exit Function
errLabel:
    objDatabase.DatabaseError
    GoTo remClear
End Function
'格式化日期
Public Function FormatDateStr(ByVal oldDate As Date, ByVal datetype As String) As String
   If datetype = "long" Then
       FormatDateStr = Year(oldDate) & "/" & Month(oldDate) & "/" & Day(oldDate)
   Else
       FormatDateStr = Month(oldDate) & "/" & Day(oldDate)
   End If
End Function
'格式化時間
Public Function FormatTimeStr(ByVal oldDate As Date, ByVal timetype As String) As String
   If timetype = "long" Then
       FormatTimeStr = Hour(oldDate) & ":" & Minute(oldDate) & ":" & Second(oldDate)
   Else
       FormatTimeStr = Hour(oldDate) & ":" & Minute(oldDate)
   End If
End Function
Public Sub InitColorLayout(ComboCustomer As ComboBox, table As String)
    Dim rs As ADODB.Recordset
    On Error GoTo errLabel
    Set rs = New ADODB.Recordset
    With rs
      .CursorLocation = adUseClient
      .CursorType = adOpenDynamic
      .LockType = adLockOptimistic
      Set .ActiveConnection = Cn
    End With
    rs.Open "select * from " & table
    
    On Error Resume Next
    ComboCustomer.Text = ""
    Do While Not rs.EOF
       ComboCustomer.AddItem rs.Fields("eColorLayout") + " " + rs.Fields!ColorLayout + " " + rs.Fields!Process
       rs.MoveNext
    Loop
    rs.Close
remClear:
    Set rs = Nothing
    Exit Sub
errLabel:
    GoTo remClear
    objDatabase.DatabaseError
End Sub
Public Sub spModiProcess(ByVal spOrderNo As String, ByVal spItemDate As String, ByVal spProcess As Integer) '更新加工单工艺時間
     Dim comm As ADODB.Command
     Set comm = New ADODB.Command
     With comm
          .ActiveConnection = Cn
          .CommandText = "pModiProcess"
          .CommandType = adCmdStoredProc
          .Prepared = True
          .Parameters.Append .CreateParameter("@iOrderNo", adVarChar, adParamInput, 20, spOrderNo)
          .Parameters.Append .CreateParameter("@iItemDate", adVarChar, adParamInput, 20, spItemDate)
          .Parameters.Append .CreateParameter("@iProcess", adInteger, adParamInput, 4, spProcess)
          .Execute
     End With
End Sub