classfunction.cls

来自「一个关于电脑管理汽车的软件」· CLS 代码 · 共 435 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassFunction"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public VarPrice As Long
Public CurrentKeyIndex As Long
Private FinishedBS() As Boolean
Public CurrentFinishIndex As Long
Public Sub CreateAllUserToMysql(ByVal UserName As String, ByVal Password As String)
 Dim TempSQL As String
 Dim TempCnn As MYSQL_CONNECTION
 
 Set TempCnn = New MYSQL_CONNECTION
 With gCnn
  TempCnn.OpenConnection .HostName, .UserName, .Password, "mysql"
 End With
 TempSQL = "GRANT ALL PRIVILEGES ON *.* TO '" & Trim(UserName) & "'@'%' IDENTIFIED By '" & Trim(Password) & "' WITH GRANT OPTION"
 TempCnn.Execute TempSQL
 TempCnn.CloseConnection
 Set TempCnn = Nothing
End Sub

Public Sub ModifyUserToMysql(ByVal OrgUserName As String, ByVal NewUserName As String, ByVal Password As String)
 Dim TempSQL As String
 Dim TempCnn As MYSQL_CONNECTION
 Dim TempRS As New MYSQL_RS
 
 Set TempCnn = New MYSQL_CONNECTION
 With frmConnect
  TempCnn.OpenConnection .txtHost, .Combo1, .txtPassword, "mysql"
 End With
 TempSQL = "Select user, password from user Where user =" & Quote(OrgUserName)
 TempRS.OpenRs TempSQL, TempCnn
 TempRS.Fields(0) = NewUserName
 TempRS.Fields(1) = Password
 TempRS.CloseRecordset
 TempRS.ReleaseMemory
 Set TempRS = Nothing
 TempCnn.CloseConnection
 Set TempCnn = Nothing
End Sub

Public Function CheckMenuPopedom(ByVal VarStr As String, ByVal ItemNumber As Long) As Boolean
 Dim PopedomIndex As Long
 If GPopedomBS(1) = True Then
    CheckMenuPopedom = True
 Else
 Select Case VarStr
  Case "Maintenance"
   Select Case ItemNumber
    Case 1, 4, 7  '"更换操作员"
     CheckMenuPopedom = True
     Exit Function
    Case 3, 5 '"操作员设置"
     CheckMenuPopedom = False
     Exit Function
   End Select
  Case "Data"
    Select Case ItemNumber
     Case 1
      PopedomIndex = 2
     Case 2
      PopedomIndex = 3
     Case 3
      PopedomIndex = 4
     Case 5
      PopedomIndex = 5
     Case 6
      PopedomIndex = 6
     Case 7
      PopedomIndex = 7
     Case 9
      PopedomIndex = 8
     Case 10
      PopedomIndex = 9
     Case 11
      PopedomIndex = 10
     Case 13
      PopedomIndex = 11
     Case 14
      PopedomIndex = 12
    End Select
  Case "StockTable"
   Select Case ItemNumber
    Case 1 '"进货单"
     PopedomIndex = 13
    Case 2 '"进货退货处理"
     PopedomIndex = 14
    Case 4 '"进（退）货历史单据"
     PopedomIndex = 15
   End Select
  Case "StoreGoods"
   Select Case ItemNumber
    Case 1
     PopedomIndex = 16
    Case 2
     PopedomIndex = 17
    Case 4
     PopedomIndex = 18
   End Select
  Case "SellTable"
   Select Case ItemNumber
    Case 1
     PopedomIndex = 19
    Case 2
     PopedomIndex = 20
    Case 4
     PopedomIndex = 21
    Case 6
     PopedomIndex = 22
    Case 8
     PopedomIndex = 23
   End Select
  Case "Maintain"
   Select Case ItemNumber
    Case 1
     PopedomIndex = 24
    Case 3
     PopedomIndex = 25
    Case 5
     PopedomIndex = 26
    Case 7
     PopedomIndex = 27
   End Select
  Case "Stat"
   Select Case ItemNumber
    Case 1
     PopedomIndex = 28
    Case 3 To 7
     PopedomIndex = 29 - 3 + ItemNumber
    Case 9
     PopedomIndex = 34
    Case 10
     PopedomIndex = 35
    Case 11
     PopedomIndex = 36
   End Select
  Case "Account"
   Select Case ItemNumber
    Case 1
     PopedomIndex = 37
    Case 2
     PopedomIndex = 38
   End Select

  End Select
  CheckMenuPopedom = GPopedomBS(PopedomIndex)
 End If
End Function
Public Sub ListViewLoad2(lvwData As Control, rs As MYSQL_RS, VarHistory As ChangeHistory)
    On Error Resume Next
     
    Dim lngCounter As Long
     
    Dim FirstColumn As Boolean
    Dim TempRS As New MYSQL_RS
    Dim TempStr As String
    Dim TempLow As Long
    Dim TempCount As Long
    Dim TempSQL As String
    'Dim TempHistory As ChangeHistory
    
    lvwData.View = lvwReport                    'THESE PARAMETERS CREATE
    lvwData.LabelEdit = lvwManual               'A DATAGRID-LIKE APPEARANCE
    lvwData.GridLines = True
    lvwData.FullRowSelect = True
     
    lvwData.ListItems.Clear
    lvwData.ColumnHeaders.Clear
    
    VarHistory.KeyCount = 0
    VarHistory.DelKeyCount = 0
    TempLow = 0
    TempCount = 0
    TempSQL = "Select * From chinesetable " 'where englishname = " & Quote(TempStr)
    
    Set TempRS = gCnn.Execute(TempSQL)
    For lngCounter = 0 To rs.FieldCount - 1
        TempStr = rs.Fields(lngCounter).Name
       With rs.Fields(lngCounter + 1)
        If TempStr = "AKey" Or TempStr = "typebs" Or ((TempStr = "billnum" Or TempStr = "drawbillnum") And ((.Name = "goodscoding") Or (.Name = "itemcode") Or (.Name = "datacontxt"))) Then
          If ((.Name = "goodscoding") Or (.Name = "itemcode") Or (.Name = "datacontxt")) And (TempStr = "billnum" Or TempStr = "drawbillnum") Then TempLow = TempLow + 1
         If TempStr = "AKey" Then TempLow = TempLow + 1
        Else
         With TempRS
          .MoveFirst
          .MovePrevious
          .FindNext "englishname", TempStr
          lvwData.ColumnHeaders.Add , , .Fields(2).Value
         End With
         TempCount = TempCount + 1
        End If
       End With
    Next
    TempRS.CloseRecordset
    TempRS.ReleaseMemory
    Set TempRS = Nothing
     
    'PREALLOCATE MEMORY FOR ROWS
    SendMessage lvwData.hWnd, LVM_SETITEMCOUNT, TempCount, 0&
     
    Dim MyItems As MSComctlLib.ListItems
    Set MyItems = lvwData.ListItems
     
    Do Until rs.EOF
        FirstColumn = True      'FIRST COLUMN IS A LISTITEM, REST ARE LISTSUBITEMS
        'Set TempHistory = VarHistory
        For lngCounter = TempLow To rs.FieldCount - 1
         If rs.Fields(lngCounter).Name <> "typebs" Then
            If FirstColumn Then
                If Not IsNull(rs.Fields(lngCounter).Value) Then
                    MyItems.Add , , rs.Fields(lngCounter).Value
                    TempCount = rs.Fields(0).Value
                  If TempLow > 0 Then VarHistory.AddRecordlstKey TempCount
                Else
                    MyItems.Add , , ""  'NULL FIELDS NEED A BLANK ITEM
                End If                  'TO KEEP DATA FROM SHIFTING LEFT
                FirstColumn = False
            Else
                If Not IsNull(rs.Fields(lngCounter).Value) Then
                    MyItems(MyItems.Count).ListSubItems.Add , , rs.Fields(lngCounter).Value
                Else
                    MyItems(MyItems.Count).ListSubItems.Add , , ""
                End If
            End If
          End If
        Next
      '  If Not IsMissing(Owner) Then Owner.pbrProgress.Value = (rs.AbsolutePosition / rs.RecordCount) * 100
        rs.MoveNext
    Loop

End Sub
Public Function MaxValue(ByVal CurrentValue As Long, ByVal KeyIndex As Long, ByVal FinishedIndex As Long)
 If CurrentValue >= VarPrice Then
   VarPrice = CurrentValue
   CurrentKeyIndex = KeyIndex
   CurrentFinishIndex = FinishedIndex
 End If
End Function
Public Function MinValue(ByVal CurrentValue As Long, ByVal KeyIndex As Long, ByVal FinishedIndex As Long)
 If VarPrice = 0 Then
  VarPrice = CurrentValue
  CurrentKeyIndex = KeyIndex
   CurrentFinishIndex = FinishedIndex
  Exit Function
 End If
 If CurrentValue <= VarPrice Then
   VarPrice = CurrentValue
   CurrentKeyIndex = KeyIndex
   CurrentFinishIndex = FinishedIndex
 End If
End Function
Public Function DealSellOrder(VarRS As MYSQL_RS, SellGoodsWay As Long) As Long
Dim i As Integer
i = 0
VarPrice = 0
CurrentKeyIndex = 0
CurrentFinishIndex = 0
With VarRS
 .MoveFirst
 Do Until .EOF
   i = i + 1
   Select Case SellGoodsWay
   Case 0
    If FinishedBS(i) = False Then MaxValue .Fields("goodsprice"), .Fields(0), i
   Case 1
    If FinishedBS(i) = False Then MinValue .Fields("goodsprice"), .Fields(0), i
   Case 2
   Case 3
  End Select
  .MoveNext
 
 Loop
End With
FinishedBS(CurrentFinishIndex) = True
End Function
Public Sub InitFinishBS(ByVal VarCount As Long)
 ReDim FinishedBS(1 To VarCount)
End Sub
Public Sub ReleaseClass()
 Dim NullBS() As Boolean
 VarPrice = 0
 CurrentKeyIndex = 0
 CurrentFinishIndex = 0
 FinishedBS = NullBS
End Sub
Public Function FindSameVariant(ByVal VarVariant As Variant, VarVariants() As Variant, VariantsLen As Long, Optional VarPos As Long) As Boolean
 Dim i As Long
 For i = 1 To VariantsLen
  If VarVariant = VarVariants(i) Then
   VarPos = i
   FindSameVariant = True
   Exit Function
  End If
 Next i
 FindSameVariant = False
End Function
Public Function FindSameDate(ByVal VarDate As Date, VarDates() As Date, DatesLen As Long) As Boolean
 Dim i As Long
 For i = 1 To DatesLen
  If VarDate = VarDates(i) Then
   FindSameDate = True
   Exit Function
  End If
 Next i
 FindSameDate = False
End Function
Public Function DefFormat(ByVal VarVariant As Variant) As String
 DefFormat = Format(VarVariant, "0.00")
End Function
Public Sub ListViewLoad3(lvwData As Control, rs As MYSQL_RS, Optional PageNum As Long = 0)
'---------------------------------------------------------------------------------------
' Procedure : ListViewLoad
' DateTime  : 03/07/04 14:09
' Author    : Robert Rowe
' Purpose   : Modified to work with VBMySQLDirect
'---------------------------------------------------------------------------------------

'THIS FUNCTION IS USED TO TAKE DATA FROM A ADODB RECORDSET AND LOAD IT INTO
'A LISTVIEW CONTROL. PLACING A PROGRESS BAR NAMED pbrProgress ON OWNER FORM
'WILL ALLOW FOR AN UPDATING PROGRESS BAR TO SHOW HOW FAR ALONG YOU ARE WHEN
'OWNER PARAMETER IS SPECIFIED DURING CALL.
'
'NOTE: LISTVIEWS ARE NOT VERY EFFICIENT WITH MEMORY, AND THIS FUNCTION
'IS NOT RECCOMENDED FOR RECORDSETS WITH > 10,000 RECORDS
'
'AUTHOR: MIKE HILLYER
'
'USAGE: ListViewLoad lvwMyListView, rsMyRecordset[, me]
 
    On Error Resume Next
     
    Dim lngCounter As Long
     
    Dim FirstColumn As Boolean
    Dim TempRS As New MYSQL_RS
    Dim TempStr As String
    Dim TempLow As Long
    Dim TempCount As Long
    Dim TempSQL As String
    Dim i As Long
    
    lvwData.View = lvwReport                    'THESE PARAMETERS CREATE
    lvwData.LabelEdit = lvwManual               'A DATAGRID-LIKE APPEARANCE
    lvwData.GridLines = True
    lvwData.FullRowSelect = True
     
    lvwData.ListItems.Clear
    lvwData.ColumnHeaders.Clear
    
    TempLow = 0
    TempCount = 0
    TempSQL = "Select * From chinesetable " 'where englishname = " & Quote(TempStr)
    Set TempRS = gCnn.Execute(TempSQL)
    For lngCounter = 0 To rs.FieldCount - 1
        TempStr = rs.Fields(lngCounter).Name
       With rs.Fields(lngCounter + 1)
        If TempStr = "AKey" Or TempStr = "typebs" Or ((TempStr = "billnum" Or TempStr = "drawbillnum") And ((.Name = "goodscoding") Or (.Name = "itemcode") Or (.Name = "datacontxt"))) Then
          If ((.Name = "goodscoding") Or (.Name = "itemcode") Or (.Name = "datacontxt")) And (TempStr = "billnum" Or TempStr = "drawbillnum") Then TempLow = TempLow + 1
         If TempStr = "AKey" Then TempLow = TempLow + 1
        Else
         With TempRS
          .MoveFirst
          .MovePrevious
          .FindNext "englishname", TempStr
          lvwData.ColumnHeaders.Add , , .Fields(2).Value
         End With
         TempCount = TempCount + 1
        End If
      End With
    Next
    TempRS.CloseRecordset
    TempRS.ReleaseMemory
    Set TempRS = Nothing
 
    'PREALLOCATE MEMORY FOR ROWS
    SendMessage lvwData.hWnd, LVM_SETITEMCOUNT, TempCount, 0&
     
    Dim MyItems As MSComctlLib.ListItems
    Set MyItems = lvwData.ListItems
    If PageNum = -1 Then
     PageNum = (rs.RecordCount - 1) \ VarInitData.EachPageRSCount
     If PageNum < 0 Then PageNum = 0
    End If
    If PageNum > 0 Then
     i = PageNum * VarInitData.EachPageRSCount
     If rs.RecordCount > i Then
      rs.Move i, 1
     Else
      PageNum = PageNum - 1
     End If
    End If
    i = 0
    Do Until (rs.EOF Or i >= VarInitData.EachPageRSCount)
        FirstColumn = True      'FIRST COLUMN IS A LISTITEM, REST ARE LISTSUBITEMS
        For lngCounter = TempLow To rs.FieldCount - 1
          If rs.Fields(lngCounter).Name <> "typebs" Then
            If FirstColumn Then
                If Not IsNull(rs.Fields(lngCounter).Value) Then
                    MyItems.Add , , rs.Fields(lngCounter).Value
                Else
                    MyItems.Add , , ""  'NULL FIELDS NEED A BLANK ITEM
                End If                  'TO KEEP DATA FROM SHIFTING LEFT
                FirstColumn = False
            Else
                If Not IsNull(rs.Fields(lngCounter).Value) Then
                    MyItems(MyItems.Count).ListSubItems.Add , , rs.Fields(lngCounter).Value
                Else
                    MyItems(MyItems.Count).ListSubItems.Add , , ""
                End If
            End If
          End If
        Next
     '   If Not IsMissing(Owner) Then Owner.pbrProgress.Value = (rs.AbsolutePosition / rs.RecordCount) * 100
        rs.MoveNext
        i = i + 1
    Loop
    If MyItems.Count > 1 Then
     lvwData.SortKey = 0
     lvwData.SortOrder = 0
     lvwData.Sorted = True
    End If

End Sub