module.bas

此为我2001年为东莞建发楦头开发的企业管理软件他们使用至今,望斑竹指教! 其他会员最好不要随意下载,需经斑竹同意或我本人同意,谢谢!

Attribute VB_Name = "公共内容"
Public db As Connection
Public number As String '主从关系值
Public trimstring As String  '录入一个符查询
Public Checkflag As String   '检测各个FORM
Public checkform As String
Public destvalue As String
Public findflag As String
Public pubfindtb As Recordset
Public sqlcc1 As String
Public sqlcc2 As String
Public opvalue As String
Public namevalue As String
Public passvalue As String
Public exitflag As String
Public mzhiwu As String '职务
Public rs As DAO.Recordset
Public DataBaseName As String
Public PCheck As String
Public Pdelete As Boolean

Public PreportType As String

Public ChFindflag As String
Public ChAddflag As String
Public PcheckStk As String
Public SqlConn As String
Public SqlConn1 As String



'-----------------------
Global Const MSG1 = "数据已经存在,不能重复"
Global Const MSG2 = "提示信息"
Global Const HELP1 = " A:增加,D:删除 S:查找,C:修改,F2:取消 B:明细 F4:保存 "

Sub main()
        If App.PrevInstance Then
           MsgBox "程式已经启动，不能再开！！！", vbCritical
           Exit Sub
           
        Else
        frmSplash.Show
        End If

End Sub


'--------------------------------
 '  这个过程主要用来查询明细编码
'--------------------------------
Public Sub ptnofind(tb1 As Recordset, str As String, number As String)

    '如果数据库为空时退出
    If tb1.RecordCount = 0 Then Exit Sub

    '录入资料
    Dim aa As Variant, strvalue As String, stresult As String
    aa = tb1.Bookmark
    strvalue = InputBox$("请输入要查询的" & str & "资料:", MSG2)
    If strvalue = "" Then Exit Sub
    strvalue = Mid(strvalue, 1, 25)
    stresult = number & " like " & "'" & strvalue & "*" & "'"

    '开始查找
    tb1.MoveFirst
    tb1.Find stresult

    '开始查找
    If tb1.EOF Then
        MsgBox "没有此" & str & "的基本资料!!!", vbCritical + vbOKOnly, MSG2
        tb1.Bookmark = aa
    End If
End Sub


'-------------------------------------
'   这个过程在报表打印时进行初始化
'-------------------------------------
Public Sub printini(DAO As DDActiveReports.DataControl, name As DDActiveReports.ActiveReport)
    With DAO
      .ConnectionString = SqlConn
      .Source = sqlcc2
     .Refresh
    End With
    
    With name
      .TOCEnabled = False
      .Toolbar.Tools(2).Caption = "打印..."
      .Toolbar.Tools(12).Caption = "前一页..."
      .Toolbar.Tools(13).Caption = "下一页..."
      .PrintWidth = 11200
    End With
    
End Sub

'--------------------------------------
'   这个过程将在选择得到焦点时产生全选
'-------------------------------------
Public Sub gotfocus(txtfields As TextBox)
    txtfields.SelStart = 0
    txtfields.SelLength = Len(txtfields.Text)
End Sub

'--------------------------------------
'   这个过程将在初始化资料
'-------------------------------------
Public Sub Preport(ReportTypeA As String, ChkFLAG As String)
  PreportType = ReportTypeA
  PCheck = ChkFLAG
  frmprint.Show 1
End Sub

'------------------------------------------------------------
'   这个过程转换录入时大小写，并按键时使其它按按钮得到焦点
'------------------------------------------------------------
Public Sub EnterDown(KeyAscii As Integer, stextbox As Object, cmd As CommandButton, Index As Integer, max As Integer)
     If KeyAscii >= Asc("a") And KeyAscii <= Asc("z") Then KeyAscii = KeyAscii + Asc("A") - Asc("a")
     If KeyAscii = 13 Then
        If Index <> max Then
           Index = Index + 1
           stextbox(Index).SetFocus
        Else
           cmd.SetFocus
        End If
     End If
End Sub


'---------------------------------------------------
'   这个过程对各种不同的单据进行查询单号
'---------------------------------------------------
Public Sub Numberfind(tb1 As Recordset, str As String, number As String)
    If tb1.RecordCount = 0 Then Exit Sub
    Dim aa As Variant, strvalue As String, stresult
    aa = tb1.Bookmark
    strvalue = InputBox$("请输入要查询的" & str & "单号:", MSG2)
    If strvalue = "" Then Exit Sub
    strvalue = Mid(strvalue, 1, 11)
    stresult = number & " like " & "'" & strvalue & "*" & "'"

    '查找相关的值
    tb1.MoveFirst
    tb1.Find stresult

    '开始查找
    If tb1.EOF Then
        MsgBox "没有此" & str & "的基本资料!!!", vbCritical + vbOKOnly, MSG2
        tb1.Bookmark = aa
    End If
End Sub

'-----------------------------------------
'  设置文本框的焦点(上，下光标移动)
'-----------------------------------------
Sub focusSet(ByRef KeyCode As Integer, objArr As Object, Index As Integer) ', maxIndex As Integer, minIndex As Integer)
    Select Case KeyCode
    Case vbKeyUp
        If Index > objArr.LBound Then
            objArr(Index - 1).SetFocus
            KeyCode = 0
        End If
    Case vbKeyDown
        If Index < objArr.UBound Then
            objArr(Index + 1).SetFocus
            KeyCode = 0
        End If
    End Select
End Sub


'------------------------------------------------------------
'这个子过程用它的 Err 码显示错误信息，并且
'如果是数据访问类型错误，就提示显示 Errors 集合
'------------------------------------------------------------
Sub ShowError()
    Dim sTmp As String
    Screen.MousePointer = vbDefault

    sTmp = "发生了下面的错误：" & vbCrLf & vbCrLf
    '添加错误字符串
    sTmp = sTmp & err.Description & vbCrLf
    '添加错误号
    sTmp = sTmp & err
  
    Beep
    '检查看错误是否源于数据库 errors 集合
    If DBEngine.Errors.Count > 0 Then
        If DBEngine.Errors(0).number = err Then
        '添加错误提示显示 errors 集合
        sTmp = sTmp & vbCrLf & vbCrLf
        '鸣笛并显示错误
        If MsgBox(sTmp, vbYesNo + vbQuestion) = vbYes Then
             Exit Sub
        End If
        Else
        MsgBox sTmp
        End If
    Else
        MsgBox sTmp
    End If
End Sub

'-----------------------------------
' 限制只允许输入数字，小数点
'-----------------------------------
Public Sub ChkNum(ChkFLAG As String, KeyAscii As Integer, obj As Object, Index As Integer)
  If ChkFLAG = "True" Then
     If KeyAscii = 8 Then
           ElseIf KeyAscii = 46 Then
           If InStr(1, obj(Index).Text, ".") <> 0 Then
                 KeyAscii = 0
                 Beep
           End If
     ElseIf KeyAscii < 48 Or KeyAscii > 57 Then
                KeyAscii = 0
                Beep
     End If
  End If
End Sub

'-------------------------------------------
' 查找资料
'--------------------------------------------
Public Sub GenBrowse(mtrimstring As String, mcheckform As String, mcheckflag As String)
   checkform = mcheckform
   trimstring = mtrimstring
   Checkflag = mcheckflag
   frmgenbrowse.Show 1
End Sub
'---------------------------------------------
'   显示操作员
'----------------------------------------------
Public Sub opdisplay(txtuserid As String, lblop As Label)
    Dim emptb As Recordset
    Set emptb = New Recordset
    emptb.Open "select op,name from op where op=" & "'" & txtuserid & "'", db, adOpenStatic, adLockOptimistic
    If emptb.RecordCount <> 0 Then
         lblop.Caption = emptb!name
    Else
         lblop.Caption = ""
    End If
End Sub

'---------------------------------------------
'   显示客户名称
'----------------------------------------------
Public Sub clientdisplay(tabledef As String, num As String, lblvendor As Label)
    Dim clienttb As New Recordset
    Set clienttb = New Recordset
    clienttb.Open "select * from " & tabledef & " where clino=" & "'" & num & "'", db, adOpenStatic, adLockOptimistic
    If clienttb.RecordCount <> 0 Then
         If IsNull(clienttb!s_name) = False Then
            lblvendor.Caption = clienttb!s_name
          Else
            lblvendor.Caption = ""
         End If
    Else
        lblvendor.Caption = ""
    End If
End Sub