bascomm.bas

注释：用VB开发的进销存系统源码

Attribute VB_Name = "basComm"

Option Explicit


Function GetCommandLine(Optional MaxArgs)
   '声明变量。
   Dim c, CmdLine, CmdLnLen, InArg, I, NumArgs
   '检查是否提供了 MaxArgs 参数。
   If IsMissing(MaxArgs) Then MaxArgs = 10
   ' 使数组的大小合适。
   ReDim Argarray(MaxArgs)
   NumArgs = 0: InArg = False
   '取得命令行参数。
   CmdLine = Command()
   CmdLnLen = Len(CmdLine)
   '以一次一个字符的方式取出命令行参数。
   For I = 1 To CmdLnLen
      c = Mid(CmdLine, I, 1)
      '检测是否为 space 或 tab。
      If (c <> " " And c <> vbTab) Then
         '若既不是 space 键，也不是 tab 键，
         '则检测是否为参数内含之字符。
         If Not InArg Then
         '新的参数。
         '检测参数是否过多。
            If NumArgs = MaxArgs Then Exit For
               NumArgs = NumArgs + 1
InArg = True
            End If
         '将字符连接到当前参数中。
         Argarray(NumArgs) = Argarray(NumArgs) & c
      Else
         '找到 space 或 tab。
         '将 InArg 标志设置成 False。
         InArg = False
      End If
   Next I
   '调整数组大小使其刚好符合参数个数。
   ReDim Preserve Argarray(NumArgs)
   If NumArgs = 0 Then
        Argarray(0) = "空"
   Else
        Argarray(0) = CStr(NumArgs)
   End If
    
   '将数组返回。
   GetCommandLine = Argarray()
End Function

Public Function DX(num2 As Integer) As String
    If num2 > 10 Or Len(Trim(Str(num2))) <> 1 Then Exit Function
    If num2 = 1 Then DX = "壹"
    If num2 = 2 Then DX = "贰"
    If num2 = 3 Then DX = "叁"
    If num2 = 4 Then DX = "肆"
    If num2 = 5 Then DX = "伍"
    If num2 = 6 Then DX = "陆"
    If num2 = 7 Then DX = "柒"
    If num2 = 8 Then DX = "捌"
    If num2 = 9 Then DX = "玖"
    If num2 = 0 Then DX = "零"
End Function

Public Function D2X(number As Single) As String
    Dim s As String
    Dim s1 As String
    Dim s2 As String
    Dim Num As Single
    Dim tt
    Num = Abs(number)
    s = Str(Num)
    If InStr(1, s, ".") <> 0 Then
       s1 = Mid(s, 1, InStr(1, s, "."))
       s2 = Mid(s, InStr(1, s, ".") + 1)
    Else
       s1 = s
    End If
    Num = Val(s1)
    s = "△"
    If Num >= 100000 And Num < 1000000 Then
        tt = Num \ 10000
        s = s & DX(tt \ 10) & "拾"
        tt = tt Mod 10
        s = s & DX(tt \ 1) & "万"
        Num = Num Mod 10000
    End If
    
    If Num < 100000 Then If Num \ 100000 <> 0 Then s = s & DX(Num \ 100000) & "拾"
    Num = Num Mod 100000
    If Num \ 10000 <> 0 Then s = s & DX(Num \ 10000) & "万"
    Num = Num Mod 10000
    If Num \ 1000 <> 0 Then s = s & DX(Num \ 1000) & "仟"
    Num = Num Mod 1000
    If Num \ 100 <> 0 Then s = s & DX(Num \ 100) & "佰"
    Num = Num Mod 100
    If Num \ 10 <> 0 Then s = s & DX(Num \ 10) & "拾"
    Num = Num Mod 10
    s = s & DX(Num \ 1) & "圆"
    If s2 <> "" Then
          s = s & DX(Val(Mid(s2, 1, 1))) & "角"
          If Len(s2) >= 2 Then s = s & DX(Mid(s2, 2, 1)) & "分"
    End If
    D2X = s
End Function


Public Function GeneratePurcode(TBName As String) As String
    On Error Resume Next
    sSQL = "SELECT ISNULL(MAX(表单号),'0000000') FROM " & TBName
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    GeneratePurcode = Format(Val(RsTemp(0)) + 1, "0000000")
End Function


Public Function IsOK() As Boolean
    Dim V1 As String, V2 As String
    Dim I
    V1 = GetSetting("Microsoft", "SoftWare", "SN", "123456")
    V2 = GetSetting("Microsoft", "SoftWare", "Secret", "123456")
    For I = 1 To Len(V1)
        If ((Val(Mid(V1, I, 1)) * 3 + 6) Mod 10) <> Mid(V2, Len(V2) - I + 1, 1) Then
            IsOK = False
            Exit Function
        End If
    Next I
    IsOK = True
End Function


Public Sub CheckIndent()
    On Error GoTo CheckErr
    sSQL = "SELECT 表单号 FROM 订货单 WHERE 到货日期<'" & Format(Now, "YYYY-MM-DD") & "'" & _
        " AND 到货标志=0"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    If Not RsTemp.EOF Then
        While Not RsTemp.EOF
            Temp = Temp & RsTemp("表单号") & vbCrLf
            RsTemp.MoveNext
        Wend
        If GetSetting("LSDSTAR", "订单设置", "警告方式", True) Then
            MsgBox "警告：有订货单到期，但货没到!!" & vbCrLf & "表单号为:" & Temp
        Else
            Beep
            Beep
            Beep
        End If
    End If
    Exit Sub
CheckErr:
    MsgBox "检查订货单时发生错误!", vbExclamation, "错误窗口"
End Sub

Public Sub SetFormToCenter(f As Form)
    f.Move (frmMain.ScaleWidth - f.ScaleWidth) / 2, (frmMain.ScaleHeight - f.ScaleHeight) / 2
End Sub

Public Function LoginSuccess(Code As String, Pwd As String) As Boolean
    On Error Resume Next
    If Code = "administrator" And Pwd = "FreeSoft" Then
        LoginSuccess = True
        UserName = "administrator"
        Exit Function
    End If
    sSQL = "SELECT * FROM 人员档案 WHERE STAFFCODE='" & Code & "'" & _
        " AND PASSWORD='" & Pwd & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    If RsTemp.EOF Then
        LoginSuccess = False
    Else
        LoginSuccess = True
        UserName = RsTemp("NAME")
    End If
End Function

'通用SQL执行函数
'当成功时返回 0
'当执行失败时返回错误号

Public Function RunSQL(sSQL As String) As Integer
    On Error GoTo MyErr:
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    RunSQL = 0
    Exit Function
MyErr:
    RunSQL = Err.number
    ErrNum = Err.number
'    Err.Clear
End Function

'通用SQL执行函数
Public Function OpenRS(sSQL As String, Optional rCurType = adOpenStatic, Optional rLockType = adLockReadOnly) As ADODB.Recordset
    Dim t As New ADODB.Recordset
    On Error GoTo MyErr:
    Set t = Nothing
    t.Open sSQL, Conn, rCurType, rLockType
    Set OpenRS = t
    Set t = Nothing
    Exit Function
MyErr:
    Set OpenRS = Nothing
    ErrNum = Err.number
'    Err.Clear
End Function

Public Function AnalyseCondition(strCond As String, IsStr As Boolean) As String
    Dim strTemp As String
    strCond = Trim(strCond)
    Select Case Mid(strCond, 1, 1)
        Case ">", "<", "!"
            If Mid(strCond, 2, 1) = "=" Then
                strTemp = Mid(strCond, 1, 2)
                strCond = Mid(strCond, 3, Len(strCond) - 2)
            Else
                strTemp = Mid(strCond, 1, 1)
                strCond = Mid(strCond, 2, Len(strCond) - 1)
            End If
        Case "="
            strTemp = "="
            strCond = Mid(strCond, 2, Len(strCond) - 1)
        Case "%", "*"
            strTemp = " like "
        Case Else
            If IsStr Then
                strTemp = " like "
            Else
                strTemp = " = "
            End If
    End Select
    If IsStr Then
        strTemp = strTemp & "'" & strCond & "'"
    Else
        strTemp = strTemp & strCond
    End If
    AnalyseCondition = strTemp
End Function


'将字符串中一个引号变成两个引号.
Public Function StrCon(strSQL As String) As String
    Dim strTemp As String
    Dim I As Integer
    strTemp = strSQL
    For I = 1 To Len(strSQL)
        If (Asc(Mid(strTemp, I, 1)) < 32 And Asc(Mid(strTemp, I, 1)) > 0) Then
            Mid(strTemp, I, 1) = " "
        End If
    Next I
    Do
        If (InStr(1, strTemp, "'") = 0) Then
            StrCon = StrCon + strTemp
            Exit Do
        End If
        StrCon = StrCon + Left(strTemp, InStr(1, strTemp, "'")) + "'"
        strTemp = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "'"))
    Loop