modglobal.bas

本程序源码是由vb编写的

Attribute VB_Name = "modGlobal"
'数据库的DSN
Public Const adDsn = ";UID=;PWD=JL8l3t45z"
Public Const adCmdText = &H1
Public ConData As String
Public Const ConStr = ";UID=;PWD=Youme1907"

'动画光标文件
'Public AniFile As String
Public Const sShopName = "环球专卖店"
Public Const sShopID = "YSL0001"
Public CodeQua As Integer
Public CodeName(1 To 9) As String
Public IsEffect As Boolean
Public Start_print As PosPrint

'权限控制
Public Authority(8) As Integer

'打印设置参数
Public PrintSetChange As Boolean

'自定义颜色
Public BackColor1 As Long '定义背景色1
Public BackColor2 As Long '定义背景色2
Public SelectForeColor As Long '网络的选定时的前景与背影
Public SelectBackColor As Long

'表单ID
Public FormID As String

Public bDelSelect As Integer
Public cJE As Currency

'用户名及权限
Public sUserName As String
Public SheetID As String

'登录成功与否
Public LoginSucceeded As Boolean

'选择供应商窗体是否Hide
Public SupplerForm As Boolean

Public Type GridCoord
      Row As Integer
      Col As Integer
End Type

Public Type ProductRef
       ID As String
       Name As String
       Price As Currency
       Unit As String
       Exsite As Boolean
End Type

Public Sub MovePic(cMoveControl As PictureBox, bMoveTrue As Boolean, cParentControl As Form, cHideFocus As Control, cShowFocus As Control)
  
    On Error Resume Next
    Dim x As Long
    If bMoveTrue = True Then
        If IsEffect = True Then
            cMoveControl.Visible = True
            Do Until cMoveControl.left >= 0
              cMoveControl.left = cMoveControl.left + x
              x = x + 1
              If cMoveControl.left >= 0 Then
                 cMoveControl.left = 0
                 Exit Do
              End If
              DoEvents
            Loop
          Else
           cMoveControl.left = 0
           cMoveControl.Visible = True
        End If
           cShowFocus.SetFocus
      Else
        If IsEffect = True Then
            Do Until cMoveControl.left < -(cMoveControl.Width)
               cMoveControl.left = cMoveControl.left - x
               x = x + 10
               If cMoveControl.left < -(cMoveControl.Width) Then
                  cMoveControl.left = 0 - cMoveControl.Width
                  Exit Do
               End If
               DoEvents
            Loop
          Else
           cMoveControl.left = 0 - cMoveControl.Width
           cMoveControl.Visible = False
        End If
        cMoveControl.Visible = False
        cHideFocus.SetFocus
    End If
       'cParentControl.Refresh

End Sub

Public Function Encrypt(ByVal strSource As String, ByVal Key1 As Integer) As String
    
    Dim bLowData As Byte
    Dim bHigData As Byte
    Dim i As Integer
    Dim strEncrypt As String
    Dim strChar As String
    For i = 1 To Len(strSource)
    
      '从待加（解）密字符串中取出一个字符
      strChar = Mid(strSource, i, 1)
    
      '取字符的低字节和Key1进行异或运算
      bLowData = AscB(MidB(strChar, 1, 1)) Xor Key1
    
      '取字符的高字节和K2进行异或运算
      bHigData = AscB(MidB(strChar, 2, 1))
    
      '将运算后的数据合成新的字符
      strEncrypt = strEncrypt & ChrB(bLowData) & ChrB(bHigData)
    
    Next
    Encrypt = strEncrypt
    
End Function

Public Sub Main()
      
   Set Start_print = New PosPrint
   '启动封面
    frmSplash.Show
   'frmMain.Show
   
End Sub

Public Sub LoadForm(bLoadStarting As Boolean)
   
   Screen.MousePointer = 11
  If bLoadStarting = True Then
  '预装入内存，以提高速度
   Load frmAcount
   Load frmChart
   Load frmMain
   Load frmOrder
   Load frmSaleForm
   Load frmStore
   '...
   
   Else
   '御载
   Unload frmAcount
   Unload frmChart
   Unload frmOrder
   Unload frmSaleForm
   Unload frmStore
   Set frmAcount = Nothing
   Set frmChart = Nothing
   Set frmOrder = Nothing
   Set frmSaleForm = Nothing
   Set frmStore = Nothing
   '...
   
  End If
   Screen.MousePointer = 0
End Sub

Public Sub checkPath(strCorrect As String)

   '检测数据文件是否存在
    Dim FS As String, FN As Long
    If strCorrect = "" Then
      FS = GetSetting(App.EXEName, "Option", "DataPath", ConData)
    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, "网络路径错误"
   Dim sTMp As String
   If left(App.Path, 1) = ":" Then
      sTMp = App.Path & "Sys\SysData.Dat"
      Else
      sTMp = App.Path & "\Sys\SysData.Dat"
   End If
   ConData = sTMp
   SaveSetting App.EXEName, "Option", "DataPath", ConData
   
End Sub

Public Function NullValue(sFields As Field) As String

  If IsNull(sFields) Then
     NullValue = ""
  Else
     NullValue = sFields.Value
  End If
  
End Function

Public Sub SavePrintSet(sPrint As PosPrint, sType As String, sFormID As String)

 '检测数据库是否完整
  'On Error Resume Next
  Dim Con As Database
  Dim rRecord As Recordset
  Dim sSQL As String
  Set Con = OpenDatabase(ConData, 0, 0, ConStr)
  sSQL = "Select * From PrintSet Where FormID='" & sFormID & "'"
  Set rRecord = Con.OpenRecordset(sSQL, dbOpenDynaset)
     If rRecord.BOF And rRecord.EOF Then  '如果没有配置时，自动加一
        rRecord.AddNew  '缺省为A4纸张
        rRecord.Fields("FormID") = sFormID
        rRecord.Fields("PageSize") = 0
        rRecord.Fields("PageWidth") = 210
        rRecord.Fields("PageHeight") = 297
        rRecord.Fields("RowHeight") = 9
        rRecord.Fields("Border") = 1
        rRecord.Fields("PageLeft") = 10
        rRecord.Fields("PageTop") = 10
        rRecord.Fields("Head10") = sPrint.N_Head10
        rRecord.Fields("Head11") = sPrint.N_Head11
        rRecord.Fields("Head2") = sPrint.N_Head2
        rRecord.Fields("sTitle") = sPrint.N_TiTle
        Dim x As Integer, sCol As String
        For x = 1 To sPrint.N_Grid.Cols - 1
           If sCol = "" Then
              sCol = Trim(CStr(x))
            Else
              sCol = sCol & "," & Trim(CStr(x))
           End If
        Next
        rRecord.Fields("Cols") = sCol
        sPrint.N_Cols = sCol
        rRecord.Update
        rRecord.Close
        Exit Sub
        'sSQL = "Select * From PrintSet Where FormID='" & sFormID & "'"
        'Set rRecord = Con.OpenRecordset(sSQL, dbOpenDynaset)
     End If
  If sType = "Save" Then
    rRecord.Edit
    rRecord.Fields("sTitle") = sPrint.N_TiTle
    rRecord.Fields("PageSize") = sPrint.N_PageSize
    rRecord.Fields("PageWidth") = sPrint.N_PageWidth
    rRecord.Fields("PageHeight") = sPrint.N_PageHeight
    rRecord.Fields("RowHeight") = sPrint.N_RowHeight
    rRecord.Fields("Border") = sPrint.N_Border
    rRecord.Fields("PageLeft") = sPrint.N_PageLeft
    rRecord.Fields("PageTop") = sPrint.N_PageTop
    rRecord.Fields("Cols") = sPrint.N_Cols
    rRecord.Fields("Head10") = sPrint.N_Head10
    rRecord.Fields("Head11") = sPrint.N_Head11
    rRecord.Fields("Head2") = sPrint.N_Head2
    rRecord.Fields("FormID") = sFormID
    rRecord.Update
  Else '给出时
    sPrint.N_TiTle = NullValue(rRecord.Fields("sTitle"))
    sPrint.N_PageSize = NullValue(rRecord.Fields("PageSize"))
    sPrint.N_PageWidth = NullValue(rRecord.Fields("PageWidth"))
    sPrint.N_PageHeight = NullValue(rRecord.Fields("PageHeight"))
    sPrint.N_RowHeight = NullValue(rRecord.Fields("RowHeight"))
    sPrint.N_Border = NullValue(rRecord.Fields("Border"))
    sPrint.N_PageLeft = NullValue(rRecord.Fields("PageLeft"))
    sPrint.N_PageTop = NullValue(rRecord.Fields("PageTop"))
    sPrint.N_Cols = NullValue(rRecord.Fields("Cols"))
    sPrint.N_Head10 = NullValue(rRecord.Fields("Head10"))
    sPrint.N_Head11 = NullValue(rRecord.Fields("Head11"))
    sPrint.N_Head2 = NullValue(rRecord.Fields("Head2"))
  End If
    rRecord.Close
   Con.Close
   Set rRecord = Nothing
   Set Con = Nothing
End Sub