Attribute VB_Name = "subprg"
Public CurrDir As String '當(dāng)前工作目錄
Public CurrYear, CurrMonth, OldMonth As String  '當(dāng)前日期
Public CurrDbs As String '當(dāng)前數(shù)據(jù)庫
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) '將一個表單居中的函數(shù)
    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 = "系統(tǒng)在執(zhí)行[ " & 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


'------------------------------------------------------------
'這個函數(shù)從 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




'------------------------------------------------------------
'這個函數(shù)從 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) + "文件已經(jīng)存在,是否覆蓋?", 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