systemmodule.bas

即时通讯

Attribute VB_Name = "SystemModule"
Option Explicit
Private msgtitle As String           ' 提示信息的标题


Public Enum enumIcon
   hxxdError = 1        '错误
   hxxdQuery = 2        '询问
   hxxdWarning = 3      '警告
   hxxdInfomation = 4   '信息
End Enum

'信息框类型
Public Enum enumMsgType
   hxxdOKOnly = 0       '确定
   hxxdOkCancel = 2     '确定/取消
   hxxdYesNo = 1        'Yes/No
End Enum

' BOM结点定义
Public Type BomNode
    name As String
    processName As String
    fee As String
    bomCost As String
    description As String
    bomId As String
    materialType As String                ' 0-原料 1-零件 2-产品
    materialId As String
    relatePartId As String               ' 相关联的零件的ID 当materialType=0，1，3时有用
                                         ' 指向相关的零件
End Type

'**************************************
'*    功 能 描 述 :系统提示函数
'*    输 入 参 数 :无
'*    输 出 能 数 :无
'**************************************
Public Function HMsgBox(xttsxx As String, xttslb As enumMsgType, Tbtslb As enumIcon)    '系统信息提示
    
    msgtitle = "山度ERP系统"
    Select Case xttslb
        Case 0    '确定
            HMsgBox = MsgBox(xttsxx, Tbtslb * 16, msgtitle)
        Case 1    'YES/NO
           HMsgBox = MsgBox(xttsxx, vbYesNo + Tbtslb * 16, msgtitle)
        Case 2    '确定/取消
           HMsgBox = MsgBox(xttsxx, vbOKCancel + Tbtslb * 16, msgtitle)
        Case Else
           HMsgBox = "9"
    End Select

End Function
'**************************************
'*    功 能 描 述 :把窗体显示到屏幕 中间
'*    输 入 参 数 :无
'*    输 出 能 数 :无
'**************************************
Public Function SetToCenter(f As Form)
    Dim X0 As Long
    Dim Y0 As Long
    
    '让窗体居中
    X0 = Screen.Width
    Y0 = Screen.Height
    X0 = (X0 - f.Width) / 2
    Y0 = (Y0 - f.Height) / 2
    f.Move X0, Y0

End Function
'**************************************
'*    功 能 描 述 :产生单据的编号
'*    输 入 参 数 :billKind   -   单据的种类
'*                          0 -   生产计划单
'*                          1 -   生产单
'*                          2 -   采购订单
'*                          3 -   采购入库
'*                          4 -   退货
'*    输 出 能 数 :无
'**************************************
Public Function GetBillNo(billKind As Integer) As String
    Dim str As String
    Dim ret As Boolean
    
    GetBillNo = ""
    
    Select Case billKind
        Case 0                         ' 生产计划单
            GetBillNo = "SCJH" + FormatD(Date) + FormatT()
        Case 1                         ' 生产计划单
            GetBillNo = "SCD" + FormatD(Date) + FormatT()
        Case 2
            GetBillNo = "CGD" + FormatD(Date) + FormatT()
        Case 3
            GetBillNo = "CGRK" + FormatD(Date) + FormatT()
        Case 4
            GetBillNo = "TH" + FormatD(Date) + FormatT()
    End Select
       
End Function
'**************************************
'*    功 能 描 述 :把日期格式转换成字符串格式
'*    输 入 参 数 :
'*    输 出 能 数 :无
'**************************************
Public Function FormatD(d As Date) As String
    Dim sYear As String        ' 年
    Dim sMonth As String       ' 月
    Dim sDay As String         ' 日

    sYear = Year(d)
    sMonth = Month(d)
    sDay = Day(d)
    
    If Len(sMonth) < 2 Then       ' 如果月只有一位,则把其转换成二位
        sMonth = "0" & sMonth
    End If
    
    If Len(sDay) < 2 Then        ' 如果日只有一位,则把其转换成二位
        sDay = "0" & sDay
    End If
    
    FormatD = sYear & sMonth & sDay
End Function
'**************************************
'*    功 能 描 述 :取得当前时间,并把时间格式转换成字符串格式
'*    输 入 参 数 :
'*    输 出 能 数 :无
'**************************************
Public Function FormatT() As String
    Dim sHour As String           ' 时
    Dim sMinute As String         ' 分
    Dim sSecond As String         ' 秒

    sHour = Hour(Time)
    sMinute = Minute(Time)
    sSecond = Second(Time)
    
    
    If Len(sHour) < 2 Then          ' 如果时只有一位,则把其转换成二位
        sHour = "0" & sHour
    End If
    
    If Len(sMinute) < 2 Then        ' 如果分只有一位,则把其转换成二位
        sMinute = "0" & sMinute
    End If
    
    If Len(sSecond) < 2 Then        ' 如果秒只有一位,则把其转换成二位
        sSecond = "0" & sSecond
    End If
    
    FormatT = sHour & sMinute & sSecond
End Function
'**************************************
'*    功 能 描 述 :替换字符串中的字符
'*    输 入 参 数 :SearchLine   -   源字符串
'*                 SearchFor    -   被替换的字符
'*                 ReplaceWith  -   新字条款
'*    输 出 能 数 :无
'**************************************
Function sReplace(SearchLine As String, SearchFor As String, ReplaceWith As String) As Boolean
    Dim vSearchLine As String, found As Integer
    
    sReplace = False
    
    found = InStr(SearchLine, SearchFor): vSearchLine = SearchLine
    If found <> 0 Then
        vSearchLine = ""
        If found > 1 Then vSearchLine = Left(SearchLine, found - 1)
        vSearchLine = vSearchLine + ReplaceWith
        If found + Len(SearchFor) - 1 < Len(SearchLine) Then _
            vSearchLine = vSearchLine + Right$(SearchLine, Len(SearchLine) - found - Len(SearchFor) + 1)
            
        sReplace = True
    End If
    SearchLine = vSearchLine
End Function
'**************************************
'*    功 能 描 述 :设置mshflexgrid一行的颜色
'*    输 入 参 数 :grid   -   MSHFlexGrid表
'*                 row    -   行
'*                 color  -   颜色
'*    输 出 能 数 :无
'**************************************
Public Function SetRowColor(ByRef grid As Object, _
                            row As Integer, _
                            color As Long)
    Dim objName
    objName = TypeName(grid)
    If StrConv(Trim(objName), vbUpperCase) <> "MSHFLEXGRID" Then
        Exit Function
    End If

    grid.FillStyle = 1

    grid.row = row

    grid.col = 0
    grid.ColSel = grid.Cols - 1
    grid.CellBackColor = color
    
    grid.FillStyle = 0
'    MSHFlexGrid.CellBackColor = &H80FFFF

End Function
'**************************************
'*    功 能 描 述 :设置mshflexgrid的对齐方式
'*    输 入 参 数 :grid   -   MSHFlexGrid表
'*                 alignMod    -   对齐方式
'*    输 出 能 数 :无
'**************************************
Public Function SetMSHFlexGridAlign(grid As MSHFlexGrid, _
                            alignMod As Integer)
    Dim row, col As Integer
    
    For row = 0 To grid.Rows - 1
        For col = 0 To grid.Cols - 1
            grid.row = row
            grid.col = col
            If grid.row = 0 Then
                grid.CellAlignment = 5 '居中对齐
            Else
                grid.CellAlignment = alignMod '对齐方式
            End If
        Next col
    Next row

End Function
'**************************************
'*    功 能 描 述 :取得新的ID编号
'*    输 入 参 数 :无
'*    输 出 能 数 :无
'**************************************
Public Function NewId() As String
    Dim dao As MainDAO
     
    Set dao = New MainDAO
    
    NewId = dao.NewId()

End Function
'**************************************
'*    功 能 描 述 :返回包括中文字符的字符串的长度
'*    输 入 参 数 :
'*    输 出 能 数 :无
'**************************************
Function CLen(HzStr$) As Integer
    Dim l As Integer
    Dim n As Integer