module1.bas

一个简单进销存系统

Attribute VB_Name = "Module1"
Option Explicit
Public fMainForm As frmMain
Public pubConn As New ADODB.Connection
Public rsName As New ADODB.Recordset


Sub Main()
    Dim fLogin As New frmLogin
  '  frmSplash.Show
  '  frmSplash.Refresh
    fLogin.show vbModal
    If Not fLogin.OK Then
        '登录失败，退出应用程序
        End
    End If
    Unload fLogin
    If Date > DateSerial(2009, 4, 20) Then
        End
    End If
    '打开数据库
    Dim strSQl As String
    strSQl = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\data.mdb" & ";Jet OLEDB:Database Password=13623290828;"
    pubConn.Open strSQl, "admin", ""
    rsName.CursorLocation = adUseClient

    Set fMainForm = New frmMain
    Load fMainForm
 '   Unload frmSplash
    fMainForm.show
End Sub

Public Sub SearchName(frm1 As dlgIncome)
    Dim strSQl As String
    Dim strName     As String
    strName = Trim(frm1.Text2.Text)
    strSQl = "select 批号,颜色,支数 from stock where [批号] like '%" & strName & "%' order by 批号"
    If rsName.State = adStateOpen Then
        rsName.Close
    End If
    rsName.Open strSQl, pubConn, adOpenStatic, adLockReadOnly
    If rsName.RecordCount = 0 Then
        '进行库存添加
        Dim AddProduct As New dlgAddPorduct
        Set AddProduct.frm1 = frm1
        AddProduct.bHaveFrm = True
        AddProduct.show vbModal
        
    Else
        If rsName.RecordCount = 1 Then
                frm1.Text2.Text = rsName!批号
                If Not IsNull(rsName!颜色) Then
                    frm1.Text7.Text = rsName!颜色
                End If
                frm1.Text8.Text = rsName!支数
                frm1.bSure = True
        Else
        
        '进行货品选择
            Dim SelName As New dlgSelNameI
            Set SelName.frm1 = frm1
            SelName.show vbModal
        End If
    End If

    If rsName.State = adStateOpen Then
        rsName.Close
    End If
End Sub
Public Sub SearchName2(frm1 As dlgSale)
'销售时批号查找
    Dim strSQl As String
    Dim strName     As String
    strName = Trim(frm1.Text2.Text)
    strSQl = strSQl = "select 批号,颜色,支数,重量 from stock where [批号] like '%" & strName & "%' order by 批号"
     If rsName.State = adStateOpen Then
        rsName.Close
    End If
   
    rsName.Open strSQl, pubConn, adOpenStatic, adLockReadOnly
    If rsName.RecordCount = 0 Then
        '进行库存添加
        MsgBox "没有相匹配的科目。请重新输入科目。"
    Else
        If rsName.RecordCount = 1 Then
                frm1.Text2.Text = rsName!批号
                If Not IsNull(rsName!批号) Then
                    frm1.Text7.Text = rsName!颜色
                End If
                frm1.Text10.Text = rsName!支数
        Else
        
        '进行货品选择
            Dim SelName As New dlgSelNameS
            Set SelName.frm1 = frm1
            SelName.show vbModal
        End If
    End If

    If rsName.State = adStateOpen Then
        rsName.Close
    End If

End Sub

Public Function printSale(lPZnum As Long) As Boolean
    Dim mobjExcel As Excel.Application
    Dim mobjworkbook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
    Dim rsSale As New ADODB.Recordset
    Dim strDestination, strSource As String
    Dim iLine As Integer
    Dim iCol As Integer
    Dim curTemp As Currency, strSQl As String, curSum As Currency
    strSource = App.Path & "\sendp.xls"
    strDestination = strSource
    Set mobjExcel = New Excel.Application
    curSum = 0
    Set mobjworkbook = mobjExcel.Workbooks.Open(strDestination)
    Set xlsheet = mobjworkbook.Worksheets(1)
    strSQl = "select * from sale  where 编号 = " & CStr(lPZnum) & " order by 序号"
    rsSale.CursorLocation = adUseClient
    rsSale.Open strSQl, pubConn, adOpenDynamic, adLockOptimistic
    If rsSale.RecordCount = 0 Then
        MsgBox "该编号没有记录"
        Exit Function
    End If
    rsSale.MoveFirst
    '填充凭证数据
    mobjExcel.ActiveSheet.Cells(2, 6).Value = rsSale!编号
    mobjExcel.ActiveSheet.Cells(4, 6).Value = rsSale!日期

    Dim strSendMan As String
    If IsNull(rsSale!客户名称) Then
        strSendMan = ""
    Else
        strSendMan = rsSale!客户名称
    End If
    mobjExcel.ActiveSheet.Cells(4, 1).Value = "客户名称：" & strSendMan

    If Not IsNull(rsSale!明细户) Then
        mobjExcel.ActiveSheet.Cells(4, 4).Value = "明细户：" & rsSale!明细户
    End If
    iLine = 6
    While Not rsSale.EOF
        xlsheet.Rows(iLine).Insert
  '      mobjExcel.ActiveSheet.Cells(iLine, 1).Value = iLine - 6 '不再打印序号
        mobjExcel.ActiveSheet.Cells(iLine, 1).Value = rsSale!批号
        mobjExcel.ActiveSheet.Cells(iLine, 2).Value = rsSale!颜色
        mobjExcel.ActiveSheet.Cells(iLine, 3).Value = rsSale!支数
        mobjExcel.ActiveSheet.Cells(iLine, 4).Value = rsSale!重量
        mobjExcel.ActiveSheet.Cells(iLine, 5).Value = rsSale!单价
        curTemp = rsSale!单价 * rsSale!重量
        mobjExcel.ActiveSheet.Cells(iLine, 6).Value = curTemp
        curSum = curSum + curTemp
        iLine = iLine + 1
        rsSale.MoveNext
    Wend
    mobjExcel.ActiveSheet.Cells(iLine, 6).Value = curSum
     mobjExcel.ActiveSheet.Cells(iLine + 1, 2).Value = Up(CStr(curSum))
     '打印预览
     mobjExcel.Visible = True
     xlsheet.PrintPreview
    mobjExcel.DisplayAlerts = False
    mobjExcel.Quit
    Set mobjExcel = Nothing
End Function
'转换函数
Public Function Up(Dxs As String) As String
'检测为空时
 If Trim(Dxs) = "" Then
    MsgBox "没有数字，不能转换!", vbOKOnly + 32
    Exit Function
End If
  Dim Sw As Integer, SzP As Integer, SzUp As Integer, TempStr As String, DXStr As String
  Dim imy As Integer
    Sw = Len(Trim(Dxs))
    SzP = InStr(1, Trim(Dxs), ".")
    imy = SzP
If SzP = 0 Then
   Dim i As Integer
     For i = 1 To Sw
         TempStr = Right(Trim(Dxs), i)
         TempStr = Left(TempStr, 1)
         TempStr = Converts(TempStr)
         Select Case i
           Case 1
               If TempStr = "零" Then
                  TempStr = "元"
                   Else
                  TempStr = TempStr + "元"
               End If
           Case 2
               If TempStr = "零" Then
                  TempStr = "零"
                Else
                  TempStr = TempStr + "拾"
               End If
           Case 3
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "佰"
               End If
            Case 4
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "仟"
               End If
            Case 5
               If TempStr = "零" Then
                  TempStr = "万"
                   Else
                  TempStr = TempStr + "万"
               End If
            Case 6
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "拾"
               End If
            Case 7
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "佰"
               End If
            Case 8
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "仟"
               End If
            Case 9
               If TempStr = "零" Then
                  TempStr = "亿"
                   Else
                  TempStr = TempStr + "亿"
               End If
         End Select
    Dim TempA As String
        TempA = Left(Trim(DXStr), 1)
    If TempStr = "零" Then
      Select Case TempA
       Case "零"
            DXStr = DXStr
       Case "元"
            DXStr = DXStr
       Case "万"
            DXStr = DXStr
       Case "亿"
            DXStr = DXStr
       Case Else
            DXStr = TempStr + DXStr
      End Select
      Else
       DXStr = TempStr + DXStr
    End If
     Next
  Else
    For i = 1 To SzP - 1
         TempStr = Right(Trim(Dxs), i + (Sw - SzP + 1))
         TempStr = Left(TempStr, 1)
         TempStr = Converts(TempStr)
         Select Case i
           Case 1
               If TempStr = "零" Then
                  TempStr = "元"
                   Else
                  TempStr = TempStr + "元"
               End If
           Case 2
               If TempStr = "零" Then
                  TempStr = "零"
                Else
                  TempStr = TempStr + "拾"
               End If
           Case 3
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "佰"
               End If
            Case 4
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "仟"
               End If
            Case 5
               If TempStr = "零" Then
                  TempStr = "万"
                   Else
                  TempStr = TempStr + "万"
               End If
            Case 6
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "拾"
               End If
            Case 7
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "佰"
               End If
            Case 8
               If TempStr = "零" Then
                  TempStr = "零"
                   Else
                  TempStr = TempStr + "仟"
               End If
            Case 9
               If TempStr = "零" Then
                  TempStr = "亿"
                   Else
                  TempStr = TempStr + "亿"
               End If
            Case Else
              '超过999999999时自动删除
              TempStr = ""
         End Select
        TempA = Left(Trim(DXStr), 1)
    If TempStr = "零" Then
      Select Case TempA
       Case "零"
            DXStr = DXStr
       Case "元"
            DXStr = DXStr
       Case "万"
            DXStr = DXStr
       Case "亿"
            DXStr = DXStr
       Case Else
            DXStr = TempStr + DXStr
      End Select
      Else
       DXStr = TempStr + DXStr
    End If
     Next
'计算小数
   Dim DxstrX As String, XStr As String
      XStr = Right(Trim(Dxs), Sw - SzP)
        For i = 1 To Sw - SzP
         TempStr = Left(XStr, i)
         TempStr = Right(TempStr, 1)
         TempStr = Converts(TempStr)
         Select Case i
           Case 1
            If TempStr = "零" Then
               TempStr = ""
               Else
               TempStr = TempStr + "角"
            End If
           Case 2
            If TempStr = "零" Then
               TempStr = ""
               Else
               TempStr = TempStr + "分"
               End If
            Case Else
              '超过两位小数时，自动删除
              TempStr = ""
         End Select
        DxstrX = DxstrX + TempStr
     Next
     DXStr = DXStr + DxstrX
End If

    Up = DXStr
    If imy = 0 Then
        Up = DXStr + "整"
    End If
End Function

Function Converts(NumStr As String) As String
    Select Case Val(NumStr)
      Case 0
        Converts = "零"
      Case 1
        Converts = "壹"
      Case 2
        Converts = "贰"
      Case 3
        Converts = "叁"
      Case 4
        Converts = "肆"
      Case 5
        Converts = "伍"
      Case 6
         Converts = "陆"
      Case 7
         Converts = "柒"
      Case 8
         Converts = "捌"
      Case 9
         Converts = "玖"
    End Select
End Function