mdlmshfview.bas

一个简单的快餐店收银软件

Attribute VB_Name = "mdlmshfView"
Option Explicit
'**********************************************
'*    模块 名 称  : Setcaption
'*    功 能 描 述 :设置MSHFVIEW控件的标题
'*    程序员姓名  : 罗胸怀
'*    最后修改人  : 罗胸怀
'*    最后修改时间:2005-02-09
'*    备        注:格式为  Call Setcaption(mshfView, "序号;款号;名称;颜色;备注;")
'*                 MSHFVIEW第0列不使用，如上面有5个标题，则MSHFVIEW列数为6
'**********************************************

Public Sub Setcaption(mshf As MSHFlexGrid, Caption As String)
Dim intCirvar As Integer
Dim Colname As String
Dim ColVar As Integer
With mshf
         Colname = ""
         ColVar = 0
         For intCirvar = 1 To Len(Caption)
             If Mid(Caption, intCirvar, 1) <> ";" Then
                Colname = Colname & Mid(Caption, intCirvar, 1)
             Else
                .TextMatrix(0, ColVar) = Colname
                Colname = ""
                ColVar = ColVar + 1
             End If
         Next
      For intCirvar = 0 To .Cols - 1
       .ColAlignmentFixed = 4
      ' If intCirvar = 1 Or intCirvar = 2 Then
      '      .ColAlignment(intCirvar) = 2
      ' ElseIf intCirvar = 4 Then
            .ColAlignment(intCirvar) = 4
      ' End If
      Next
      .RowHeightMin = 300 '最后添加
End With
End Sub

'**********************************************
'*    模块 名 称  : CreateSerial
'*    功 能 描 述 :产生mshfview的序列号
'*    程序员姓名  : 罗胸怀
'*    最后修改人  : 罗胸怀
'*    最后修改时间:2005-02-09
'*    备        注:格式为  Call CreateSerial(mshfView)
'**********************************************
Public Function CreateSerial(mshf As MSHFlexGrid)
Dim iCnt As Integer
With mshf
    For iCnt = 1 To .Rows - 1
        .TextMatrix(iCnt, 0) = iCnt
    Next
End With
End Function
'填充网格数据
Public Function ShowData(Sql As String, mshf As MSHFlexGrid, Minrows As Integer) As Integer
Dim intCir As Date
Dim Colname As String
Dim ColVar As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim Fld As Field
Dim Rss As New ADODB.Recordset
On Error GoTo errorhandle
If Rss.State <> 0 Then Rss.Close
Rss.CursorLocation = adUseClient
Rss.Open Sql, Conn, adOpenForwardOnly, adLockReadOnly
Cleardata mshf
With mshf
    If Rss.EOF And Rss.BOF Then
        .Rows = Minrows
        ShowData = 0
        For iRow = 1 To .Rows - 1
            .TextMatrix(iRow, 0) = iRow
        Next
    Else
        Rss.MoveLast
        .Rows = Rss.RecordCount + 1
        If .Rows < Minrows Then
            .Rows = Minrows
        End If
        For iRow = 1 To .Rows - 1
            .TextMatrix(iRow, 0) = iRow
        Next
         ShowData = Rss.RecordCount
        .Cols = Rss.Fields.Count + 1
        
        Rss.MoveFirst
    End If
    iRow = 1
    .Redraw = False
    Do While Not Rss.EOF
       For iCol = 0 To .Cols - 1
                If iCol = 0 Then
                    .TextMatrix(iRow, 0) = iRow
                Else
                    .TextMatrix(iRow, iCol) = Rss.Fields(iCol - 1) & ""
                End If
       Next
       'Fancy mshf, iRow
        Rss.MoveNext
        iRow = iRow + 1
    Loop
    'For iRow = 1 To Rss.RecordCount - 1
    '    For iCol = 0 To Rss.Fields.Count - 1
    '        If iCol = 0 Then
    '               .TextMatrix(iRow, 0) = iRow
    '        Else
    '                .TextMatrix(iRow, iCol) = Rss.Fields(iCol - 1) & ""
    '        End If
    '    Next
    '    Rss.MoveNext
    'Next
    .Redraw = True
End With
If Rss.State <> 0 Then Rss.Close
Set Rss = Nothing
ex:
  Exit Function
errorhandle:
  Call DisplayConnError(Conn)
  GoTo ex
End Function

Public Sub getData(Sql As String, mshf As MSHFlexGrid, Minrows As Integer, Caption As String)
Dim intCirvar As Integer
Dim Colname As String
Dim ColVar As Integer
Dim intCir As Integer
On Error GoTo errorhandle

If Rs.State <> 0 Then Rs.Close
Rs.Open Sql, Conn, adOpenDynamic, adLockReadOnly, adCmdText
Call Dataview(mshf, Rs)

If Rs.State <> 0 Then Rs.Close
With mshf
         Colname = ""
         ColVar = 1
         For intCirvar = 1 To Len(Caption)
             If Mid(Caption, intCirvar, 1) <> ";" Then
                Colname = Colname & Mid(Caption, intCirvar, 1)
             Else
                .TextMatrix(0, ColVar) = Colname
                Colname = ""
                ColVar = ColVar + 1
             End If
       
         Next
        .SelectionMode = flexSelectionByRow
        .AllowBigSelection = True
        .AllowUserResizing = flexResizeColumns
        .ColWidth(0) = 0
        For intCir = 0 To .Cols - 1
       .ColAlignmentFixed = 4
       .ColAlignment(intCir) = 4
        Next
     If .Rows < Minrows Then .Rows = Minrows
       .Row = 1
       .RowSel = 1
       .Col = 0
       .ColSel = .Cols - 1
End With
ex:
  Exit Sub
errorhandle:
  Call DisplayConnError(Conn)
  GoTo ex
End Sub
'//////////////////////////////////////////////////////////////
'自定义过程从记录集中将数据显示在数据显示控件上
'///////////////////////////////////////////////////////////////

Public Sub Dataview(mshf As MSHFlexGrid, Rss As ADODB.Recordset)
  Dim intCirvar As Integer
  Dim Fld As Field
  With mshf
  If Not Rss.EOF Then
     Rss.MoveNext
         '*******************************************************
         '设定显示数据控件的列数
         '*******************************************************
     .Cols = Rss.Fields.Count + 1
     
     Rss.MoveFirst
     .Rows = 1
     .FixedCols = 0
     .FixedRows = 0
     .Row = 0
     .Col = 1
     
        '*********************************************************
        '设定显示数据控件的行(第一行)的标题
        '*********************************************************
'     For intCirvar = 0 To Rss.Fields.Count - 1
'       .Text = Rss.Fields(intCirvar).Name
'       If .Col < Rss.Fields.Count Then .Col = .Col + 1
'     Next
       
        '********************************************************
        '循环处理数据(从记录集中显示在数据控件上
        '********************************************************
     Do While Not Rss.EOF
       .Rows = .Rows + 1
       .Row = .Row + 1
       .Col = 1
       For Each Fld In Rss.Fields
                  '*************************
                  '判断是否为空值
                  '*************************
           If IsNull(Fld.Value) Then
              .Text = ""
           Else
                  '**************************
                  '判断是否为日期格式且日期格式长度大于11
                  '**************************
              If IsDate(Fld.Value) And Len(Fld.Value) > 11 Then
                 .Text = Format(Fld.Value, "yyyy/mm/dd hh:mm:ss")
              Else
                 .Text = Fld.Value
              End If
           End If
                  '**************************
                  '循环增加列值
                  '**************************
           If .Col < Rss.Fields.Count Then .Col = .Col + 1
       Next
      
       Rss.MoveNext
     Loop
     
        '**********************************************************
        '处理循环后显示格式
        '**********************************************************
     If .Rows > 1 Then
        .TextMatrix(1, 0) = ""
        .SelectionMode = flexSelectionByRow
        .AllowUserResizing = flexResizeColumns
        .AllowBigSelection = True
        
        .FixedCols = 1
        .FixedRows = 1
        .Row = 1
        .RowSel = 1
        .Col = 0
        .ColSel = .Cols - 1
        
     End If
  Else
       '*********************************************************
       '如果没有数据,清空数据显示控件中的数据
       '*********************************************************
    .Rows = 2
    For intCirvar = 0 To .Cols - 1
        .TextMatrix(1, intCirvar) = ""
    Next
  End If
  End With
End Sub

'********************************
'All errors is done there.
'********************************
Public Sub DisplayConnError(connect As ADODB.Connection)
Dim Er As ADODB.Error
Dim Errorprompt As String
For Each Er In connect.Errors
  Select Case Er.Number
       Case "-2147467259"
          Errorprompt = "数据库连接有误..."
'       Case "-2147217843"
          
       Case "-2147217865"
         Errorprompt = "表名有误..."
       Case "-2147217900"
          Errorprompt = "查询语句有误..."
       Case Else
          Errorprompt = "error number:" & Er.Number & vbCrLf & "source:" & Er.Source & vbCrLf & "text:" & Er.Description
  End Select
  MsgBox Errorprompt, vbOKOnly, "提示"
Next
End Sub

'清除MSHFVIEW 的数据
Public Sub Cleardata(mshfViewt As MSHFlexGrid)
Dim intCir As Integer
Dim intCircol As Integer
With mshfViewt
  For intCir = 1 To .Rows - 1
      For intCircol = 1 To .Cols - 1
          .TextMatrix(intCir, intCircol) = ""
      Next
  Next
End With
End Sub
Public Sub Delete_Click(mshf As MSHFlexGrid, Sql As String, ColDeletevalue As Integer)
Dim strSql As String
Dim intCircle As Integer
With mshf
On Error GoTo errorhandle
   If .TextMatrix(.RowSel, 1) <> "" Then
      Conn.Execute Sql & .TextMatrix(.RowSel, ColDeletevalue) & "'"
      If .Rows > 2 Then
        .RemoveItem .RowSel
      Else
        For intCircle = 1 To .Cols - 1
            .TextMatrix(1, intCircle) = ""
        Next
      End If
      .Row = 1
      .RowSel = 1
      .Col = 0
      .ColSel = .Cols - 1
   End If
End With
ex:
 Exit Sub
errorhandle:
 Call DisplayConnError(Conn)
 GoTo ex
End Sub

Public Sub mshf_click(mshf As MSHFlexGrid)
With mshf
       .Col = 0
       .ColSel = .Cols - 1
End With
End Sub

Public Sub Fancy(mshf As MSHFlexGrid, ir As Integer)
    Dim CurrentCell As Integer
    Dim r As Integer
    With mshf
        .Row = ir
        If .Row Mod 2 = 0 And .Row <> 0 Then
            '// trying to make this row diff col
            CurrentCell = .Col
            For r = 1 To .Cols - 1
                .Col = r
                .CellBackColor = &HFAEDDE       'RGB(174, 245, 214)
            Next
            .Col = CurrentCell
        End If
    End With
End Sub