modfunction.bas

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

Attribute VB_Name = "modFunction"

Global bLoad As Boolean  '安装完成时
Global bStart As Boolean '安装监视时
Global Constr As String  '数据库连接字符串
Global ConData As String '数据库字符串
Global sMemberStr As String '查询字符串
Global DateStr As String  '日期字符串
Public CancelSearch As Boolean  '取消
Public CC(5) As String
Public sUnit As String   '单位
Public sName As String  '品名
Public stype As String  '类型
Public SCondStr As String '查询条件
Public QueryStr As String '查询字符串表Select * From ***表
Public sSL As Long  '数量
Public SureQuantly As Boolean '确认订购
Public CardNO As String   '卡号
Public cJE As Currency   '讨款时的金额
Public nLast As Long 'ID打印号

Public Us As String  '管理员登录名
Public UserText As String
Public Authority(17) As Boolean

' COMBO表增量查询
Public Const CB_FINDSTRING = &H14C
Public Const LB_FINDSTRING = &H18F
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

' 打开其它程序
  Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long


Sub Main()

   Constr = ";UID=;PWD=BXS3s44yiA"
   ConData = App.Path & "\SystemData.mdb"

'   CheckPath ("")
   
 ' 启动模块
   'frmSplash.Show
        frmMain.Show

End Sub

Public Sub SaveFormSet(frmSelf As Form)

  SaveSetting App.EXEName, "Form_Positon", frmSelf.Name & "_Left", frmSelf.Left
  SaveSetting App.EXEName, "Form_Positon", frmSelf.Name & "_Top", frmSelf.Top
  SaveSetting App.EXEName, "Form_Positon", frmSelf.Name & "_width", frmSelf.Width
  SaveSetting App.EXEName, "Form_Positon", frmSelf.Name & "_height", frmSelf.Height
  
End Sub

Public Sub GetFormSet(frmSelf As Form, frmContaint As Object)

  ' 缺省值为中心
   frmSelf.Left = GetSetting(App.EXEName, "Form_Positon", frmSelf.Name & "_Left", (frmContaint.Width - frmSelf.Width) / 2)
   frmSelf.Top = GetSetting(App.EXEName, "Form_Positon", frmSelf.Name & "_Top", (frmContaint.Height - frmSelf.Height) / 2)
   frmSelf.Height = GetSetting(App.EXEName, "Form_Positon", frmSelf.Name & "_height", frmSelf.Height)
   frmSelf.Width = GetSetting(App.EXEName, "Form_Positon", frmSelf.Name & "_width", frmSelf.Width)
End Sub


Public Sub SetItFocus(sControl As Control)

    sControl.SelStart = 0
    sControl.SelLength = Len(sControl.Text)
   
End Sub

Public Sub DirectFocus(sHControl As Control, sLControl As Control, sLeftControl, sRightControl, LKey As Integer)

   'On Error Resume Next
  
   If LKey = 38 Then  '向上移
      If IsNull(sHControl) Then Exit Sub
      sHControl.SetFocus
      Exit Sub
   End If
   
   If LKey = 40 Or LKey = 13 Then '向下移
      LKey = 0
      If IsNull(sLControl) Then Exit Sub
      sLControl.SetFocus
      Exit Sub
   End If
   
   If LKey = 37 Then '向前
      If IsNull(sLeftControl) Then Exit Sub
      sLeftControl.SetFocus
      Exit Sub
   End If
   
   If LKey = 39 Then '向右
      If IsNull(sRightControl) Then Exit Sub
      sRightControl.SetFocus
      Exit Sub
   End If
   
End Sub

'Public Sub CheckPath(strCorrect As String)
'
'    Dim fs As String, FN As Long
'    If strCorrect = "" Then
'      fs = GetSetting("餐饮茶馆", "Data", "Path")
'    Else
'      fs = strCorrect
'    End If
'     FN = FreeFile
''On Error GoTo Exist_Err
'Open fs For Input As #FN
'Close #FN
'  ConData = fs
'Exit Sub
'
'Exist_Err:
'
'  MsgBox "网 络 路 径 错 误 , 现 在 启 用 本 地 数 据 库 。        " + vbCrLf + vbCrLf + "   请 重 新 定 义 网 络 数 据 库 的 路 径  ！    ", vbOKOnly + vbExclamation, "网络路径错误"
'
'  ConData = ConData
'  SaveSetting "餐饮茶馆", "Data", "Path", ConData
'
'End Sub

Public Sub DelRecord(sWP As String, sFields As String, sTable As String)

   'On Error GoTo Err_init
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, Constr)
   
   ' SQL语言删除
     sEXE = "Delete * From " & sTable & " Where " & sFields & "='" & sWP & "'"
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
          Exit Sub
Err_init:
 MsgBox "记录删除错误!    " & vbCrLf & vbCrLf & err.Description, vbCritical
 
End Sub

Public Function CheckProduct(sTable As String, sFields As String, sCode As String, iLong As Integer) As String
   
   Dim DB As Database, EF As Recordset, HH As Integer
   Set DB = OpenDatabase(ConData, False, False, Constr)
   Set EF = DB.OpenRecordset("Select * From " & sTable & " Where " & sFields & "='" & Trim(sCode) & "'", dbOpenDynaset)
       If EF.EOF And EF.BOF Then
          CheckProduct = ""
        Else
          CheckProduct = EF.Fields(iLong)
       End If
    EF.Close
    DB.Close
End Function

Public Sub DeleteRecord(sTable As String)
   
   'On Error Resume Next
  
   Dim DB As Database
   Set DB = OpenDatabase(ConData, False, False, Constr)
       Dim sTmp As String
           sTmp = "Delete * From " & sTable
       DB.Execute sTmp
    DB.Close
    
End Sub

Public Sub MyUpdateRecord(sFields As String, sValues As String, sFieldsCond As String, sCond As String, sTable As String)
   
   'On Error Resume Next
  
   Dim DB As Database
   Set DB = OpenDatabase(ConData, False, False, Constr)
    Dim Mytmp As String
        Mytmp = "Update " & sTable & " Set " & sFields & "='" & sValues & "' Where " & sFieldsCond & "='" & sCond & "'"
    DB.Execute Mytmp
    DB.Close
    
End Sub

Public Function ConVertEncry(sCode As String) As String

      Dim shiftStr As String, shiftStrR As Variant, shiftNum As Integer, ili As Integer, SureStr As String
      shiftStr = Trim(sCode)
      shiftNum = Len(shiftStr)
      ili = 1
      SureStr = ""
        For ili = 1 To shiftNum
            shiftStrR = Mid(shiftStr, ili, 1)
            shiftStrR = Asc(shiftStrR)
            shiftStrR = shiftStrR - 3
            shiftStrR = Chr(shiftStrR)
            SureStr = SureStr & shiftStrR
        Next
      ConVertEncry = SureStr
      
End Function