modpublicfunction.bas

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

Attribute VB_Name = "modPublicFunction"
Option Explicit
'公用函数模块
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVallpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function ResponseAddress Lib "AutosiDlan.dll" (ByVal strSite As String) As String
Public Declare Function ResponseVersion Lib "AutosiDlan.dll" (ByVal strSite As String) As String
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '-----Sleep函数
'begin 查找文件
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Const MAX_PATH = 260
Public Const SW_MAXIMIZE = 3
Public Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type
'end
'登录时记录日志
Public Sub LoginLog()
    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 top 1 * from tloginlog order by ID desc"
    rs.AddNew
    rs("OperatorNo") = userInf.userID
    rs("Operator") = userInf.userName
    rs("Company") = userInf.userCompany
    rs("Dept") = userInf.userDept
    rs("ComputerName") = userInf.localName
    rs("IPAddress") = userInf.localIP
    rs("MAC") = userInf.MAC
    rs("LoginDate") = GetCurTime
    rs.Update
    userInf.loginDate = GetCurTime
    userInf.loginId = rs.Fields!ID
    rs.Close
    Set rs = Nothing
    Exit Sub
errLabel:
    Set rs = Nothing
    objDatabase.DatabaseError
    'GoTo remClear
End Sub
'退出时记录日志
Public Sub QuitLog()
    Dim strSql As String
    Dim onlineDate As Date
    onlineDate = GetCurTime - userInf.loginDate
    strSql = "update tLoginLog set QuitDate=" & objDatabase.FormatSQL(GetCurTime) & ",onlinedate='" & onlineDate & "',QuitStatus=1 where id=" & userInf.loginId
    objDatabase.ExecCmd strSql
End Sub
'程序正在执行中...
Public Sub SystemExecuteStart(ByRef frm As Form)
    Screen.MousePointer = vbHourglass
    strCap = frm.Caption
    frm.Caption = "正在读取生成数据资料..."
    'frmSystemWait.Show vbModal
    'cmdButton.Enabled = False
End Sub
'程序正在执行结束
Public Sub SystemExecuteEnd(ByRef frm As Form)
    Screen.MousePointer = vbDefault
    frm.Caption = strCap
    'Stopwait = True
    'cmdButton.Enabled = True
End Sub

'窗口初始化
Public Sub FormInit(ByRef frm As Form, bFormChild As Boolean)
'bFormChild=false是对话框
'bFormChild=true是子窗口
If bFormChild = True Then
    Dim X, Y As Single
    
    'Dim iScreenx As Long, iScreeny As Long
    'Dim beilvx As Double, beilvy As Double

    frm.Width = 15300
    frm.Height = 9530 + 2055
    frm.Left = 0
    frm.Top = 0
    X = Screen.Width / Screen.TwipsPerPixelX / 1024
    frm.Width = frm.Width * X
   
    '1050
    Y = (Screen.Height - 2055) / Screen.TwipsPerPixelY / 768
    'frm.Height = (frm.Height) * y
   frm.Height = Screen.Height - 2055
    
    
    'MsgBox x & vbCrLf & y
End If
End Sub
'设置列表控件长宽度
Public Sub SetObjectWH(ByRef objControls As Object)
    
    Dim X, Y As Single
    X = Screen.Width / Screen.TwipsPerPixelX / 1024
    objControls.Width = objControls.Width * X
    objControls.Left = objControls.Left * X
    Y = (Screen.Height - objControls.Top - 2055) / Screen.TwipsPerPixelY / 768
    objControls.Height = (objControls.Height + objControls.Top + 2055) * Y
    objControls.Top = objControls.Top * Y
End Sub
'设置详细信息颜色
Public Sub SetItemBackColor(ByRef MshF As MSHFlexGrid)
Dim j, i As Long
With MshF
    .Redraw = False
    For j = 2 To .Rows - 1
       ' If MshF.TextMatrix(j, 1) = "" Then
       '    MshF.RowHeight(j) = 0
       ' End If
          If j Mod 2 = 0 Then
                .row = j
                    For i = 1 To .Cols - 1
                        .col = i
                        .CellBackColor = objDispalyIni.GetItemColor
                    Next
          Else

                .row = j
                    For i = 1 To .Cols - 1
                        .col = i
                        .CellBackColor = objDispalyIni.GetItemSpaceColor
                    Next
         End If
    Next j
    .Redraw = True
End With
End Sub
'设置货品信息颜色
Public Sub SetProductBackColor(ByRef MshF As MSHFlexGrid)
Dim j, i As Long
With MshF
    .Redraw = False
    For j = 2 To .Rows - 1
        
          If j Mod 2 = 0 Then
                .row = j
                    For i = 1 To .Cols - 1
                        .col = i
                        .CellBackColor = objDispalyIni.GetProductColor
                    Next
          Else
                .row = j
                    For i = 1 To .Cols - 1
                        .col = i
                        .CellBackColor = objDispalyIni.GetProductSpaceColor
                    Next
         End If
    Next j
    .Redraw = True
End With
End Sub
Public Function DelMshfItem(MshF As MSHFlexGrid, curValue As Long, message As String) As Boolean
    DelMshfItem = False
    If MshF.TextMatrix(curValue, 1) = "" Or curValue < MshF.FixedRows + 1 Then Exit Function
        If MsgBox("是否删除 " & MshF.TextMatrix(curValue, 1) & " 的" & message & "吗?", vbQuestion + vbYesNo, "提示") = vbNo Then Exit Function
        Dim i, j As Integer
        DelMshfItem = True
        On Error Resume Next
        For i = curValue To MshF.Rows - MshF.FixedRows
            For j = 1 To MshF.Cols - 1
                MshF.TextMatrix(i, j) = MshF.TextMatrix(i + 1, j)
           Next j
        Next i
        If MshF.Rows > MshF.FixedRows Then
            MshF.Rows = MshF.Rows - 1
            
            Dim iCount As Integer
            If MshF.TextMatrix(MshF.Rows - 1, 1) = "" Then
                MshF.TextMatrix(MshF.Rows - 1, 0) = ""
                iCount = 2
            Else
                iCount = 1
                
            End If
            MshF.TextMatrix(MshF.FixedRows, 1) = MshF.Rows - MshF.FixedRows - iCount
            'MSHF1.TextMatrix(MshF.FixedRows + 1, 10) = 0
            
        End If
    MshF.row = curValue - 1
    MshF.col = 0
    MshF.ColSel = MshF.Cols - 1
    
End Function
'空值
Public Function NullValue(strValue As Variant, Optional bNull As Boolean) As Variant
On Error GoTo errLabel
    If IsNull(strValue) Then
        If strValue.Type = 3 Then '3整数，6货币,202字符,135日期,11Bit
            NullValue = -1
        ElseIf strValue.Type = 135 Then
            If bNull = True Then
                NullValue = ""
            Else
                NullValue = "1990-1-1"
            End If
        ElseIf strValue.Type = 11 Then
            NullValue = 0
        ElseIf strValue.Type = 6 Then
            NullValue = 0
        Else
            NullValue = ""
        End If
    Else
        If strValue.Type = 6 Then
            NullValue = Format(strValue, "0.000")
        Else
            NullValue = Replace(strValue, vbNullChar, "")
        End If
        
    End If
Exit Function
errLabel:
    NullValue = ""
End Function

'导出数据
Public Function ExportExcel(MshF As MSHFlexGrid, pFilePath As String)
On Error Resume Next
Dim VBExcel As Excel.Application
Dim xlbook As Excel.Workbook '定义Excel工作簿对象
Dim xlsheet As Excel.Worksheet ' 定义Excel工作表对象
'Dim ExcelFile As String
Dim row As Integer, col As Integer
Dim strSource, strDestination As String
Dim ListRow As Integer, ListCol As Integer
Dim Fileid As Long
ListRow = MshF.Rows
ListCol = MshF.Cols
strSource = App.Path & "\setting\template.xls"
Dim WinData As WIN32_FIND_DATA  'FindFristFile得参数类型
Fileid = FindFirstFile(strSource, WinData)
 If Fileid = -1 Then
    MsgBox "没有发现模板文件，请在" & App.Path & "\setting\下新建名为template的EXCEL文件！", vbExclamation + vbOKOnly, "提示"
    Exit Function
 End If
'template.xls就是一个模版文件
'strDestination = App.Path & "\Excels\Temp.xls"
strDestination = pFilePath
FileCopy strSource, strDestination '将模版文件拷贝到一个临时文件
Set VBExcel = CreateObject("excel.application")
VBExcel.Visible = True
Set xlbook = VBExcel.Workbooks.Open(strDestination)
Set xlsheet = xlbook.Worksheets("sheet1")
xlsheet.Activate

For row = 1 To ListRow
    For col = 1 To ListCol
     xlsheet.Cells(row, col).Value = MshF.TextMatrix(row - 1, col - 1)
   Next col
Next row

xlbook.Show
xlbook.Save
'保存文件
Set xlsheet = Nothing
Set xlbook = Nothing
Set VBExcel = Nothing
'xlsheet.PrintOut '执行打印
'VBExcel.Quit '退出Excel
End Function
'枚举窗口
  Public Sub sfFormsUnload(ByRef frm As Variant)
          Dim i     As Integer
          For i = Forms.Count - 1 To 0 Step -1
                  If UCase$(Forms(i).Name) <> UCase$(frm.Name) Then
                          Unload Forms(i)
                  End If
          Next
          'sfFormsUnload = ""
  End Sub
  
'计算个人所得税
Public Function IndividualTax(totalMoney As Currency) As Currency
    Dim basicm, cha, output As Currency
    basicm = 1600
    cha = totalMoney - basicm
    If cha <= 0 Then
        output = 0
    End If
    If cha > 0 And cha <= 500 Then
        output = cha * 0.05
    End If
    
    If cha > 500 And cha <= 2000 Then
        output = cha * 0.1 - 25
    End If
    If cha > 2000 And cha <= 5000 Then
        output = cha * 0.15 - 125