CD Actual Thematic 25: Programming/pc_actual_25.iso/Basic/GridOne/setup.EXE/FORM1.VB

Text File | 2001-09-09 | 21.2 KB | 577 lines

'-----------------------------------------------------------------------------
' This is a part of the BeeGrid ActiveX control.
' Copyright ⌐ 2000 Stinga
' All rights reserved.
'
' You have a right to use and distribute the BeeGrid sample files in original
' form or modified, provided that you agree that Stinga has no warranty,
' obligations, or liability for any sample application files.
'-----------------------------------------------------------------------------
Imports System.ComponentModel
Imports System.Drawing
Imports System.WinForms
Imports BeeGridOLEDB10
Imports Microsoft.VisualBasic.Compatibility.VB6
Imports System.UInt32
#Region "BeeGrid constants import"
Imports BeeGridOLEDB10.sgAppearance
Imports BeeGridOLEDB10.sgAlignment
Imports BeeGridOLEDB10.sgAutoResize
Imports BeeGridOLEDB10.sgButtonAlignment
Imports BeeGridOLEDB10.sgCalculationType
Imports BeeGridOLEDB10.sgCellBkgStyle
Imports BeeGridOLEDB10.sgCellBorder
Imports BeeGridOLEDB10.sgCellBorderStyle
Imports BeeGridOLEDB10.sgCellEditorType
Imports BeeGridOLEDB10.sgCellKind
Imports BeeGridOLEDB10.sgCellMerge
Imports BeeGridOLEDB10.sgCellStatus
Imports BeeGridOLEDB10.sgCellTip
Imports BeeGridOLEDB10.sgConditionValueSource
Imports BeeGridOLEDB10.sgDataFormat
Imports BeeGridOLEDB10.sgCustomDrawStage
Imports BeeGridOLEDB10.sgCustomDrawResponse
Imports BeeGridOLEDB10.sgDataMode
Imports BeeGridOLEDB10.sgDataType
Imports BeeGridOLEDB10.sgDisplayType
Imports BeeGridOLEDB10.sgEllipsis
Imports BeeGridOLEDB10.sgEnterKeyBehavior
Imports BeeGridOLEDB10.sgEvenOddStyle
Imports BeeGridOLEDB10.sgExpand
Imports BeeGridOLEDB10.sgExportFlag
Imports BeeGridOLEDB10.sgFilterAction
Imports BeeGridOLEDB10.sgFocusRect
Imports BeeGridOLEDB10.sgGridBorderStyle
Imports BeeGridOLEDB10.sgGridHitTest
Imports BeeGridOLEDB10.sgGridLineStyle
Imports BeeGridOLEDB10.sgGridRedrawCode
Imports BeeGridOLEDB10.sgGroupFooterText
Imports BeeGridOLEDB10.sgGroupHeaderPicture
Imports BeeGridOLEDB10.sgGroupHeaderText
Imports BeeGridOLEDB10.sgGroupOperation
Imports BeeGridOLEDB10.sgInactiveSelection
Imports BeeGridOLEDB10.sgItemHeight
Imports BeeGridOLEDB10.sgLayoutFormat
Imports BeeGridOLEDB10.sgMaskDataMode
Imports BeeGridOLEDB10.sgMousePointer
Imports BeeGridOLEDB10.sgMultiSelect
Imports BeeGridOLEDB10.sgNavigationWrapMode
Imports BeeGridOLEDB10.sgNewRowPos
Imports BeeGridOLEDB10.sgOLEDragMode
Imports BeeGridOLEDB10.sgOLEDropMode
Imports BeeGridOLEDB10.sgOperator
Imports BeeGridOLEDB10.sgOutlineLines
Imports BeeGridOLEDB10.sgPicAlignment
Imports BeeGridOLEDB10.sgPopupAlignment
Imports BeeGridOLEDB10.sgPreviewPanePosition
Imports BeeGridOLEDB10.sgPreviewPaneType
Imports BeeGridOLEDB10.sgRangeType
Imports BeeGridOLEDB10.sgResizeAnimation
Imports BeeGridOLEDB10.sgRowStatus
Imports BeeGridOLEDB10.sgRowType
Imports BeeGridOLEDB10.sgScrollBar
Imports BeeGridOLEDB10.sgScrollBarMode
Imports BeeGridOLEDB10.sgScrollTip
Imports BeeGridOLEDB10.sgSearchFlag
Imports BeeGridOLEDB10.sgSelectionMode
Imports BeeGridOLEDB10.sgShowButton
Imports BeeGridOLEDB10.sgSortOrder
Imports BeeGridOLEDB10.sgSortType
Imports BeeGridOLEDB10.sgSpecialMode
Imports BeeGridOLEDB10.sgTabKeyBehavior
Imports BeeGridOLEDB10.sgUserResizing
Imports BeeGridOLEDB10.sgUserRowColDrag
Imports BeeGridOLEDB10.sgUserRowColHide
#End Region

Public Class Form1
#Region "Declaration section"
    Inherits System.WinForms.Form

    Private mlColCount As Integer
    Private mlRowCount As Integer
    Private mlMinesCount As Integer
    Private Const SGM_CELL_SIZE As Short = 16 '305

    Private Const MAX_WIDTH As Short = 20
    Private Const MAX_HEIGHT As Short = 20
    Private Const MIN_MINES As Short = 5

    Private Const ID_MINE As Short = 9
    Private Const ID_FLAG As Short = 10
    Private Const ID_NOMINE As Short = 11

    Private vbButtonFace As UInt32

    Private mdtStartTime As Date

    Private Enum enmPictureIds
        enmFlag = 8
        enmMine = 9
        enmNoMine = 10
    End Enum
#End Region
    Public Sub New()
        MyBase.New()

        Form1 = Me

        'This call is required by the Win Form Designer.
        InitializeComponent()

        'TODO: Add any initialization after the InitializeComponent() call
    End Sub

    'Form overrides dispose to clean up the component list.
    Public Overrides Sub Dispose()
        MyBase.Dispose()
        components.Dispose()
    End Sub

#Region " Windows Form Designer generated code "

    'Required by the Windows Form Designer
    Private components As System.ComponentModel.Container


    Private WithEvents ImageList1 As System.WinForms.ImageList
    Private WithEvents txtRowCount As System.WinForms.TextBox
    Private WithEvents txtColCount As System.WinForms.TextBox
    Private WithEvents txtMines As System.WinForms.TextBox
    Private WithEvents lblRows As System.WinForms.Label
    Private WithEvents lblColumns As System.WinForms.Label
    Private WithEvents lblMines As System.WinForms.Label
    Private WithEvents cmdGame As System.WinForms.Button
    Private WithEvents AxSGGrid1 As AxBeeGridOLEDB10.AxSGGrid

    Dim WithEvents Form1 As System.WinForms.Form

    'NOTE: The following procedure is required by the Windows Form Designer
    'It can be modified using the Windows Form Designer.
    'Do not modify it using the code editor.
    Private Sub InitializeComponent()
        Dim resources As System.Resources.ResourceManager = New System.Resources.ResourceManager(GetType(Form1))

        Me.components = New System.ComponentModel.Container()
        Me.txtMines = New System.WinForms.TextBox()
        Me.cmdGame = New System.WinForms.Button()
        Me.txtRowCount = New System.WinForms.TextBox()
        Me.lblRows = New System.WinForms.Label()
        Me.lblColumns = New System.WinForms.Label()
        Me.lblMines = New System.WinForms.Label()
        Me.ImageList1 = New System.WinForms.ImageList()
        Me.AxSGGrid1 = New AxBeeGridOLEDB10.AxSGGrid()
        Me.txtColCount = New System.WinForms.TextBox()

        AxSGGrid1.BeginInit()

        '@design Me.TrayHeight = 90
        '@design Me.TrayLargeIcon = False
        '@design Me.TrayAutoArrange = True
        txtMines.Location = New System.Drawing.Point(56, 40)
        txtMines.Text = "15"
        txtMines.TabIndex = 5
        txtMines.Size = New System.Drawing.Size(32, 20)
        txtMines.TextAlign = System.WinForms.HorizontalAlignment.Right

        cmdGame.Location = New System.Drawing.Point(8, 8)
        cmdGame.BackColor = System.Drawing.SystemColors.Control
        cmdGame.Size = New System.Drawing.Size(96, 24)
        cmdGame.TabIndex = 1
        cmdGame.Text = "&New Game"

        txtRowCount.Location = New System.Drawing.Point(144, 64)
        txtRowCount.Text = "15"
        txtRowCount.TabIndex = 7
        txtRowCount.Size = New System.Drawing.Size(32, 20)
        txtRowCount.TextAlign = System.WinForms.HorizontalAlignment.Right

        lblRows.Location = New System.Drawing.Point(104, 72)
        lblRows.Text = "Rows:"
        lblRows.Size = New System.Drawing.Size(40, 16)
        lblRows.TabIndex = 4

        lblColumns.Location = New System.Drawing.Point(0, 72)
        lblColumns.Text = "Columns:"
        lblColumns.Size = New System.Drawing.Size(56, 16)
        lblColumns.TabIndex = 3

        lblMines.Location = New System.Drawing.Point(0, 40)
        lblMines.Text = "Mines:"
        lblMines.Size = New System.Drawing.Size(56, 16)
        lblMines.TabIndex = 2

        '@design ImageList1.SetLocation(New System.Drawing.Point(7, 7))
        ImageList1.ImageSize = New System.Drawing.Size(16, 16)
        ImageList1.ImageStream = CType(resources.GetObject("ImageList1.ImageStream"), System.WinForms.ImageListStreamer)
        ImageList1.ColorDepth = System.WinForms.ColorDepth.Depth8Bit
        ImageList1.TransparentColor = System.Drawing.Color.Magenta

        AxSGGrid1.TabIndex = 0
        AxSGGrid1.Size = New System.Drawing.Size(264, 240)
        AxSGGrid1.OcxState = CType(resources.GetObject("AxSGGrid1.OcxState"), System.WinForms.AxHost.State)
        AxSGGrid1.Location = New System.Drawing.Point(0, 96)

        txtColCount.Location = New System.Drawing.Point(56, 64)
        txtColCount.Text = "15"
        txtColCount.TabIndex = 6
        txtColCount.Size = New System.Drawing.Size(32, 20)
        txtColCount.TextAlign = System.WinForms.HorizontalAlignment.Right
        Me.Text = "Form1"
        Me.AutoScaleBaseSize = New System.Drawing.Size(5, 13)
        Me.Icon = CType(resources.GetObject("$this.Icon"), System.Drawing.Icon)
        Me.ClientSize = New System.Drawing.Size(292, 349)

        Me.Controls.Add(txtRowCount)
        Me.Controls.Add(txtColCount)
        Me.Controls.Add(txtMines)
        Me.Controls.Add(lblRows)
        Me.Controls.Add(lblColumns)
        Me.Controls.Add(lblMines)
        Me.Controls.Add(cmdGame)
        Me.Controls.Add(AxSGGrid1)

        AxSGGrid1.EndInit()
    End Sub

#End Region

    Protected Sub cmdGame_Click(ByVal sender As Object, ByVal e As System.EventArgs)
        AxSGGrid1.Enabled = True
        AxSGGrid1_OnInit(sender, e)
    End Sub


    Public Sub AxSGGrid1_OnInit(ByVal sender As Object, ByVal e As System.EventArgs) Handles AxSGGrid1.OnInit

        PreInit()

        Me.Text = "Minesweeper"

        With AxSGGrid1
            .RedrawEnabled = False
            'cols & rows creation
            .DefaultColWidth = SGM_CELL_SIZE
            .DefaultRowHeight = SGM_CELL_SIZE
            .Columns.RemoveAll(True)
            .HeadingRowCount = 0
            .DataRowCount = 0
            .DataColCount = 0
            .DataColCount = mlColCount
            .DataRowCount = mlRowCount
            'disable edit end selection
            .AllowEdit = False
            .SelectionMode = sgSelectionNone
            'grid appearance
            .GroupByBoxVisible = False
            .GridBorderStyle = sgNone
            .CellsBorderVisible = False
            .BackColor = System.Drawing.SystemColors.Control
            .CtlBackColor = System.Drawing.SystemColors.Control
            .FocusRect = sgFocusRectNone
            .GridLines = sgGridLineStyle.sgGridLineNone

            vbButtonFace = .GetOleColorFromColor(system.Drawing.SystemColors.Control)

            With .Styles("Normal")
                .Font.Bold = True
                .TextAlignment = sgAlignCenterCenter
                .BackColor = vbButtonFace
                .ForeColor = vbButtonFace
                .BkgPictureAlignment = sgPicAlignCenterCenter
            End With

            With .Styles("Heading")
                .ForeColor = vbButtonFace
                .TextAlignment = sgAlignCenterCenter
                .DisplayType = sgDisplayPicture
                .BkgPictureAlignment = sgPicAlignCenterCenter
            End With

            With .CreateRange(sgRangeFree, _
               0, 0, mlColCount - 1, mlRowCount - 1)
                .ApplyStyle(AxSGGrid1.Styles("Heading"))
            End With

            SetMines()

            'resize form
            Me.Width = (mlColCount * SGM_CELL_SIZE) + _
               .Left + (Me.Width - Me.ClientRectangle.Width)
            Me.Height = (mlRowCount * SGM_CELL_SIZE) + _
               .Top + (Me.Height - Me.ClientRectangle.Height())

            .Images = ImageList1.Handle

            .RedrawEnabled = True
        End With

        mdtStartTime = Now
    End Sub

    Public Sub AxSGGrid1_MouseUp _
    (ByVal sender As Object, ByVal e As System.WinForms.MouseEventArgs) Handles AxSGGrid1.MouseUp
        Dim cell As Object
        Const vbRed As Integer = 255
        Const vbBlack As Integer = 0

        If AxSGGrid1.HitTestObject(e.X, e.Y, cell) <> sgHitCell Then Exit Sub

        If e.Button = WinForms.MouseButtons.Left Then
            AxSGGrid1.RedrawEnabled = False

            If cell.Value = "M" Then
                FlatCell(AxSGGrid1.MouseCol, AxSGGrid1.MouseRow)
                cell.Style.BackColor = vbRed
                cell.Style.ForeColor = vbBlack
                ShowAllMines()
                AxSGGrid1.RedrawEnabled = True
                AxSGGrid1.Enabled = False
                MsgBox("Boom!!!", vbExclamation)
                Exit Sub
            ElseIf cell.Value = "F" Then
                Exit Sub
            End If

            If CInt(cell.Value) = 0 Then
                cell.Tag = "Open"
                FlatCell(AxSGGrid1.MouseCol, AxSGGrid1.MouseRow)
                ShowFreeCells(cell.row.Position, cell.Column.Position)
            Else
                cell.Tag = "Open"
                FlatCell(AxSGGrid1.MouseCol, AxSGGrid1.MouseRow)


                cell.Style.ForeColor = _
                    AxSGGrid1.GetOleColorFromColor(GetCellColor(CInt(cell.Value)))
            End If

            AxSGGrid1.RedrawEnabled = True

            If CheckGameStatus Then
                MsgBox("Cool! Your time " & _
                   DateDiff("s", mdtStartTime, Now) & " seconds.", vbInformation)
                AxSGGrid1.Enabled = False
            End If

        ElseIf e.Button = WinForms.MouseButtons.Right Then
            If cell.Tag = Nothing Then
                cell.Tag = cell.Value
                cell.Value = "F"
                cell.Style.BkgPicture = _
                    AxSGGrid1.GetIPictureFromPicture(ImageList1.GetBitmap(enmPictureIds.enmFlag))
            ElseIf cell.Value = "F" Then
                cell.Value = cell.Tag
                cell.Style.Reset()
                cell.Style.ForeColor = vbButtonFace
                With AxSGGrid1.CreateRange(sgRangeFree, _
                        cell.Column.Position, cell.Row.Position, cell.Column.Position, cell.Row.Position)
                    .ApplyStyle(AxSGGrid1.Styles("Heading"))
                End With
                cell.Tag = Nothing
            End If
        End If

        AxSGGrid1.Redraw(sgGridRedrawCode.sgRedrawAll)
    End Sub

    Private Sub PreInit()

        On Error Goto PreInitError

        If mlColCount = 0 Or mlRowCount = 0 Or mlMinesCount = 0 Then
            mlColCount = 12
            mlRowCount = 12
            mlMinesCount = 15
        Else
            mlMinesCount = CInt(txtMines.Text)
            mlColCount = CInt(txtColCount.Text)
            mlRowCount = CInt(txtRowCount.Text)
            If mlColCount > MAX_WIDTH Then mlColCount = MAX_WIDTH
            If mlRowCount > MAX_HEIGHT Then mlRowCount = MAX_HEIGHT
            If mlMinesCount < MIN_MINES Then mlMinesCount = MIN_MINES
        End If

        txtRowCount.Text = CStr(mlRowCount)
        txtColCount.Text = CStr(mlColCount)
        txtMines.Text = CStr(mlMinesCount)

        Exit Sub
PreInitError:
        mlMinesCount = 0
        PreInit()
        Exit Sub
    End Sub

    Private Sub SetMines()
        Dim i As Integer, j As Integer
        Dim iMinesCount As Integer
        Dim ar As IsgArray
        Dim lRow As Integer, lCol As Integer

        On Error Resume Next

        ar = AxSGGrid1.Array

        For i = 0 To mlColCount - 1
            For j = 0 To mlRowCount - 1
                ar(j, i) = 0
            Next
        Next

        If mlRowCount * mlColCount < mlMinesCount Then
            MsgBox("Too much mines!!")
            Exit Sub
        End If

        Do
            Randomize()
            lRow = CInt(Fix(Rnd * (mlRowCount + 1))) : lCol = CInt(Fix(Rnd * (mlColCount + 1)))
            If lRow <> mlRowCount And lCol <> mlColCount Then
                If ar(lRow, lCol) <> "M" Then
                    ar(lRow, lCol) = "M"
                    iMinesCount = iMinesCount + 1
                End If
            End If
        Loop Until (iMinesCount = mlMinesCount)

        For i = 0 To mlColCount - 1
            For j = 0 To mlRowCount - 1
                If ar(j, i) = "M" Then
                    ar(j, i - 1) = CInt(ar(j, i - 1)) + 1
                    ar(j, i + 1) = CInt(ar(j, i + 1)) + 1
                    ar(j - 1, i) = CInt(ar(j - 1, i)) + 1
                    ar(j - 1, i - 1) = CInt(ar(j - 1, i - 1)) + 1
                    ar(j - 1, i + 1) = CInt(ar(j - 1, i + 1)) + 1
                    ar(j + 1, i) = CInt(ar(j + 1, i)) + 1
                    ar(j + 1, i - 1) = CInt(ar(j + 1, i - 1)) + 1
                    ar(j + 1, i + 1) = CInt(ar(j + 1, i + 1)) + 1
                End If
            Next
        Next

        ar = Nothing
    End Sub

    Private Function CheckGameStatus() As Boolean
        Dim cell As SGCell, row As SGRow

        For Each row In AxSGGrid1.Rows
            For Each cell In row.Cells
                If cell.Tag = "" And cell.Value <> "F" And cell.Value <> "M" Then
                    Exit Function
                ElseIf cell.Value = "F" And cell.Tag <> "M" Then
                    Exit Function
                End If
            Next
        Next

        CheckGameStatus = True
    End Function

    Private Sub ShowAllMines()
        Dim cell As IsgCell
        Dim row As IsgRow
        Dim hst As AxHost

        On Error Goto ShowMinesError

        For Each row In AxSGGrid1.Rows
            For Each cell In row.Cells
                If cell.Value = "M" Then
                    cell.Value = ""

                    cell.Style.BkgPicture = _
                        AxSGGrid1.GetIPictureFromPicture _
                        (ImageList1.Images(enmPictureIds.enmMine))
                ElseIf cell.Value = "F" Then
                    If cell.Tag = "M" Then
                        cell.Value = ""
                        cell.Style.BkgPicture = _
                            AxSGGrid1.GetIPictureFromPicture _
                            (ImageList1.GetBitmap(enmPictureIds.enmMine))
                    Else
                        cell.Value = ""
                        cell.Style.BkgPicture = _
                            AxSGGrid1.GetIPictureFromPicture _
                            (ImageList1.GetBitmap(enmPictureIds.enmNoMine))
                    End If
                End If
            Next
        Next
        Exit Sub
ShowMinesError:
        msgbox("error")
        Exit Sub
    End Sub

    Private Sub ShowFreeCells(ByVal lRow As Integer, ByVal lCol As Integer)
        Dim cell As IsgCell
        Dim i As Integer
        Dim lColor As Long
        Dim arRows() As Integer = _
            {lRow - 1, lRow - 1, lRow - 1, lRow, _
             lRow, lRow + 1, lRow + 1, lRow + 1}
        Dim arCols() As Integer = _
            {lCol - 1, lCol, lCol + 1, lCol - 1, _
            lCol + 1, lCol - 1, lCol, lCol + 1}

        For i = 0 To UBound(arRows)
            If (arRows(i) > -1 And arRows(i) < mlRowCount) _
               And (arCols(i) > -1 And arCols(i) < mlColCount) Then
                cell = AxSGGrid1.Rows.At(arRows(i)).Cells(arCols(i))
                If cell.Tag = Nothing Then
                    FlatCell(CInt(arCols(i)), CInt(arRows(i)))
                    cell.Tag = "Open"
                    If CInt(cell.Value) = 0 Then
                        ShowFreeCells(CInt(arRows(i)), CInt(arCols(i)))
                    Else
                        cell.Style.ForeColor = _
                            AxSGGrid1.GetOleColorFromColor(GetCellColor(CInt(cell.Value)))
                    End If
                End If
            End If
        Next
        cell = Nothing
    End Sub

    Private Sub FlatCell(ByVal lCol As Integer, ByVal lRow As Integer)
        With AxSGGrid1.CreateRange(sgRangeFree, _
            lCol, lRow, lCol, lRow)
            .ApplyStyle(AxSGGrid1.Styles("Normal"))
        End With


    End Sub

    Private Sub CenterForm(ByVal frm As Form)
        ' Centers the form on the screen.
        Dim RecForm As rectangle = Screen.GetBounds(frm)
        frm.Left = CInt((RecForm.Width - frm.Width) / 2)
        frm.Top = CInt((RecForm.Height - frm.Height) / 2)
    End Sub

    Private Function GetCellColor(ByVal iValue As Integer) As Color
        Select Case iValue
            Case 0
                Return system.Drawing.SystemColors.Control
            Case 1
                Return system.Drawing.Color.Blue
            Case 2
                Return system.Drawing.Color.DarkGreen
            Case 3
                Return system.Drawing.Color.DarkOrange
            Case 4
                Return system.Drawing.Color.OliveDrab
            Case 5
                Return system.Drawing.Color.Orchid
            Case 6
                Return system.Drawing.Color.PaleGoldenrod
            Case 7
                Return system.Drawing.Color.Beige
            Case 8
                Return system.Drawing.Color.Chocolate
        End Select
    End Function
End Class