subprg.bas

用vb写的饮食管理系统功能全面

Attribute VB_Name = "subprg"
Public CurrDir As String '当前工作目录
Public CurrYear, CurrMonth, OldMonth As String  '当前日期
Public CurrDbs As String '当前数据库
Public UserName, DepName As String
Public UserLevel, LogOK As Integer
Public PFace As String
Public Cnstr As String
'Public CurrConnect As ADODB.Connection
'Public CurrExConnect As ADODB.Connection

Public CurrQuery As String
Public CurrListNo As String
Public CurrStockNo As String
Public CurrOp As String

Public MaxOutListNo As String
Public MaxInListNo As String
Public MaxStockListNo As String

Declare Function GetSystemDirectory Lib "kernel32.dll" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function htmlhelp Lib "hhctrl.ocx" _
    Alias "HtmlHelpA" (ByVal hwnd As Long, _
    ByVal lpHelpFile As String, _
    ByVal wCommand As Long, _
    ByVal dwData As Long) As Long


Function GetSystemPath() As String

    Dim buffer As String * 255
    GetSystemDirectory buffer, 255
    GetSystemPath = StripFileName(buffer)
    
End Function


'Public Sub ABAddFlag(ByVal bandFlag As ActiveBar2LibraryCtl.BandFlags, ByVal band As ActiveBar2LibraryCtl.band)
'    band.Flags = band.Flags Or bandFlag
'End Sub
'
'Public Sub ABRemoveFlag(ByVal bandFlag As ActiveBar2LibraryCtl.BandFlags, ByVal band As ActiveBar2LibraryCtl.band)
'    band.Flags = band.Flags And Not bandFlag
'End Sub
'

Public Function GetUniqueToolID() As Long
Static STATToolId As Long

If STATToolId = 0 Then
    STATToolId = 20000
End If

STATToolId = STATToolId + 1

GetUniqueToolID = STATToolId

End Function




Public Function CenterForm(f As Form) '将一个表单居中的函数
    f.Move (Screen.Width - f.Width) \ 2, (Screen.Height - f.Height) \ 2
End Function

Public Sub ThisErrorHandle(op As String, err As String)     '错误处理
    
    If Len(op & err) = 0 Then
        ErrorHandle ErrCase
    Else
        strError = "系统在执行[ " & op & " ]操作时：" & vbCr
        strError = strError & "    " & err & vbCr
    
        MsgBox strError, vbOKOnly + vbInformation, "错误！"
   End If
End Sub

Function DirExist(dirname As String) As Boolean  '检查一个目录是否存在

    myname = Dir(dirname, vbDirectory)
    
    If Len(myname) <> 0 Then
    
        DirExist = True
    
    Else
        DirExist = False
    End If
    
End Function


'------------------------------------------------------------
'这个函数从 path\file 字符串中去掉文件名
'------------------------------------------------------------
Function StripFileName(rsFileName As String) As String
  'On Error Resume Next
  Dim i As Integer

  For i = Len(rsFileName) To 1 Step -1
    If Mid(rsFileName, i, 1) = "\" Then
      Exit For
    End If
  Next

  StripFileName = Mid(rsFileName, 1, i - 1)

End Function




'------------------------------------------------------------
'这个函数从 path\file 字符串中去掉路径
'------------------------------------------------------------
Public Function TrimFilePath(rsFileName As String) As String
'On Error Resume Next
  Dim i As Integer

  For i = Len(rsFileName) To 1 Step -1
    If Mid(rsFileName, i, 1) = "\" Then
      Exit For
    End If
  Next

  StripFilePath = Mid(rsFileName, i + 1, i - 1)

End Function


'检查一个文件是否存在
Function FileExist(FileName As String) As Boolean

'On Error GoTo err
ErrCase = ""

    Open FileName For Input As #1
    
    Close #1
    
    FileExist = True
    Exit Function
err:
    FileExist = False
End Function

'删除字符串中间的空格
Function MTrim(s As String) As String
    Dim front, temp As String
    
    temp = Trim(s)
    front = ""
    
    Do While Len(temp) > 0
        c = Asc(Left(temp, 1))
        If c <> 32 And c <> 0 Then
            front = front + Left(temp, 1)
        End If
        temp = Right(temp, Len(temp) - 1)
    Loop
     
    MTrim = front
End Function


'取公式
Function GetFamula(fstr As String) As String
    a = fstr
    GetFmula = a
End Function




Function GetWeekDay() As String
    
    Select Case Weekday(Date)
        
        Case 1
            GetWeekDay = "星期日"
            
        Case 2
            GetWeekDay = "星期一"
            
        Case 3
            GetWeekDay = "星期二"
            
        Case 4
            GetWeekDay = "星期三"
        
        Case 5
            GetWeekDay = "星期四"
        
        Case 6
            GetWeekDay = "星期五"
                              
        Case 7
            GetWeekDay = "星期六"
                              
    End Select
End Function

Public Function RplInStr(fs As String, rs As String, ss As String) As String
    
    If Len(ss) = 0 Then
        RplInStr = ""
        Exit Function
    End If
    tmp = ss
    
    pos = InStr(tmp, fs)
    If pos = 0 Then
        RplInStr = ss
        Exit Function
    End If
    
    ret = ""
    Do While pos > 0
        ret = ret + Left(tmp, pos - 1) + rs
        tmp = Right(tmp, Len(tmp) - pos - Len(fs) + 1)
        pos = InStr(tmp, fs)
    Loop
    ret = ret + tmp
    RplInStr = ret
End Function


Function GetZS(s As Variant) As Long
    Dim tt As String
    
    tt = CStr(s)
    tt = RplInStr(".", ",", tt)
    GetZS = Val(tt)
End Function

Function GetXS(s As Variant) As Single
    GetXS = (s - GetZS(s))
End Function

Function CopyFile(Bar As Object, Src As String, Dst As String, fgf As Boolean) As Single

    Static Buf() As Byte
    Dim BTest!, Fsize!
    Dim Chunk%, F1%, F2%
    
    Const BUFSIZE = 1024
    ErrCase = ""
    If FileExist(Dst) And Not fgf Then
       Response = MsgBox(Dst + Chr(10) + Chr(10) + "文件已经存在,是否覆盖?", vbYesNo + vbQuestion) 'prompt the user with a message box
       If Response = vbNo Then
          Exit Function
       Else
          Kill Dst
       End If
    Else
        If FileExist(Dst) Then
            Kill Dst
        End If
    End If
     
    'On Error GoTo FileCopyError
    
    F1 = FreeFile
    Open Src For Binary As F1
    
    F2 = FreeFile
    Open Dst For Binary As F2
     
    Fsize = LOF(F1)
    BTest = Fsize - LOF(F2)
    
    Do
        If BTest < BUFSIZE Then
           Chunk = BTest
        Else
           Chunk = BUFSIZE
        End If
              
        ReDim Buf(1 To Chunk)
        Get F1, , Buf
        Put F2, , Buf
        BTest = Fsize - LOF(F2)
        
        Bar.Value = (100 - Int(100 * BTest / Fsize))
    
    Loop Until BTest = 0
    
    Close F1
    Close F2
    CopyFile = 100
    Bar.Value = 0
    Exit Function
    
FileCopyError:
    MsgBox "文件拷贝错误!!", vbInformation + vbOKOnly, "错误"
    Close F1
    Close F2
    Exit Function

End Function



Public Function FiFo(s As Double, dec As Integer) As Double
    Dim ret As Double
    Dim tt As Long
    
    ret = s * (10 ^ dec)
    tt = CLng(ret)
    
    ret = tt / (10 ^ dec)
    FiFo = ret
End Function


Public Sub ConnectStr()
    
    If FileExist(CurrDir & "cs.ini") Then
        Cnstr = "Provider=" & ReadFromINI("DATABASE", "Provider", "MSDASQL.1", CurrDir & "cs.ini")
        Cnstr = Cnstr & ";Persist Security Info=" & ReadFromINI("DATABASE", "Persist Security Info", "False", CurrDir & "cs.ini")
        Cnstr = Cnstr & ";User ID=" & ReadFromINI("DATABASE", "User ID", "管理员", CurrDir & "cs.ini")
        Cnstr = Cnstr & ";password=" & ReadFromINI("DATABASE", "password", "sa", CurrDir & "cs.ini")
        Cnstr = Cnstr & ";Data Source=" & ReadFromINI("DATABASE", "Data Source", "suncard", CurrDir & "cs.ini")
    Else
        Cnstr = "Provider=MSDASQL.1;Persist Security Info=False;User ID=管理员;password=sa;Data Source=suncard"
        WriteINI "DATABASE", "Provider", "MSDASQL.1", CurrDir & "cs.ini"
        WriteINI "DATABASE", "Persist Security Info", "False", CurrDir & "cs.ini"
        WriteINI "DATABASE", "User ID", "管理员", CurrDir & "cs.ini"
        WriteINI "DATABASE", "password", "sa", CurrDir & "cs.ini"
        WriteINI "DATABASE", "Data Source", "suneating", CurrDir & "cs.ini"
    End If
    
End Sub


Public Function GetNo(tb As String, fd As String) As String
Dim rs As New ADODB.Recordset
Dim tt As String
Dim ret As String
    With rs
        .CursorLocation = adUseClient
        .Open "select " & fd & " from " & tb & " order by val(" & fd & ")", CurrConnect, adOpenStatic, adLockReadOnly
    End With
    
    If rs.RecordCount > 0 Then
        rs.MoveLast
        tt = rs.Fields(0).Value
        
        
        ret = Space(Len(tt) - Len(CStr(Val(tt)))) & CStr(Val(tt) + 1)
        
        GetNo = RplInStr(" ", "0", ret)
    Else
        GetNo = CurrMonth & "0001"
    End If
    
    
    rs.Close
    Set rs = Nothing
    
End Function

Public Sub GetMaxNo()
Dim rs As New ADODB.Recordset
    With rs
        .CursorLocation = adUseClient
        .Open "select * from tb_jxcno where month='" & CurrMonth & "'", CurrConnect, adOpenStatic, adLockReadOnly
    End With
    
    MaxInListNo = rs!MaxInListNo
    MaxOutListNo = rs!MaxInListNo
    MaxStockListNo = rs!MaxStockListNo

    rs.Close
    Set rs = Nothing
    
End Sub

Public Function SetMaxNo() As Boolean
'On Error GoTo er:
    CurrConnect.BeginTrans
    CurrConnect.Execute "update tb_jxcno set " & _
                        "MaxInListNo = '" & MaxInListNo & "'," & _
                        "MaxOutListNo ='" & MaxInListNo & "'," & _
                        "MaxStockListNo ='" & MaxStockListNo & _
                        " where month='" & CurrMonth & "';"
    SetMaxNo = True
    CurrConnect.CommitTrans
    Exit Function
er:
    SetMaxNo = False
    If CurrConnect.Errors.Count > 0 Then
        CurrConnect.RollbackTrans
        ErrorHandle CurrConnect.Errors.Item(0).Description
        CurrConnect.Errors.Clear
    Else
        ErrorHandle ""
    End If

End Function


Public Function get2month(cm As Integer) As String

    If cm > 9 Then
        get2month = CStr(cm)
    Else
        get2month = "0" & CStr(cm)
    End If
End Function

Public Function GetMaxCode(c As String) As String
    Dim t As String
    Dim ret As String
    
    If Len(c) = 0 Or Not IsNumeric(c) Then
        t = "0"
    End If
    t = CStr(Val(c) + 1)
    ret = t
    For i = 1 To Len(c) - Len(t)
        ret = "0" & ret
    Next
    GetMaxCode = ret
End Function