VB-MSHFlexGrid常用的功能代码

1. 直接将查询数据填入MSHFLEXGRID

Sub QueryFromSybasebyCon(Condition)

With QEvent ‘ QEvent为Form名称

   Con.Open strConnRemote

        rs.CursorLocation = adUseClient

        rs.CursorType = adOpenKeyset

         On Error Resume Next

         Rs.Open "select * where" & Condition & " order by event_ts", Con, 3, 1 ‘Condition为SQL查询条件

         .MSHFlexGrid1.Redraw = False ‘重绘，可大大提高Grid的格式化后显示速度

         Set .MSHFlexGrid1.DataSource Rs

      Set Rs = Nothing

   Set Con = Nothing

End With

End Sub

 

 

2. 设置MSHFlexGrid的格式

Sub FormatFlexGrid()

 

           With QEvent.MSHFlexGrid1

                 If .Rows > 1 And .TextMatrix(1, 1) <> "" Then

                      'Set Column width

                      .ColWidth(0) = 3000

                       'Set Column header

                       .TextMatrix(0, 0) = "Test"

                     ‘设置对齐

                    .ColAlignment(5) = flexAlignRightCenter

                   End If

                   ‘设置整行的颜色

                  .Redraw = False

                .Row = 3

                .Col = 0

                .ColSel = .Cols - 1

                .CellBackColor = RGB(254, 216, 209)

 

                .Redraw = True

           End With

End Sub

 

 

3. 支持滚轮事件

‘模块部分

          Public Cn As New ADODB.Connection

Public Const GWL_WNDPROC = (-4)

Public Const WM_COMMAND = &H111

Public Const WM_MBUTTONDOWN = &H207

Public Const WM_MBUTTONUP = &H208

Public Const WM_MOUSEWHEEL = &H20A

Public Oldwinproc         As Long

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, _

    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

     

Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _

ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

     

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, _

    ByVal nIndex As Long) 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

 

           ‘支持鼠标动作的函数

              Public Function FlexScroll(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

            Select Case wMsg

                  Case WM_MOUSEWHEEL

                  Select Case wParam

                          Case -7864320             '向下滚动

                                SendKeys "{PGDN}"

   

                          Case 7864320                 '向上滚动

                                SendKeys "{PGUP}"

                  End Select

          End Select

          FlexScroll = CallWindowProc(Oldwinproc, hwnd, wMsg, wParam, lParam)

       End Function

 

       ‘窗体中的程序

       Private Sub MSHFlexGrid1_GotFocus()

           Oldwinproc = GetWindowLong(Me.hwnd, GWL_WNDPROC)

            SetWindowLong Me.hwnd, GWL_WNDPROC, AddressOf FlexScroll

       End Sub

       Private Sub MSHFlexGrid1_LostFocus()

           SetWindowLong Me.hwnd, GWL_WNDPROC, Oldwinproc

       End Sub

4. 支持键盘事件

        Private Sub MSHFlexGrid1_KeyDown(KeyCode As Integer, Shift As Integer)

Dim X As Long

Dim Y As Long

Dim L As Long

Dim Tmp As String

X = MSHFlexGrid1.Col

Y = MSHFlexGrid1.Row

Select Case KeyCode '功能或扩展

   Case 46 ‘响应删除Delete键

          MSHFlexGrid1.Text = ""

Case vbKeyC '响应Ctrl+C 复制功能             

          Clipboard.Clear

          Call ExportExcelclip(QEvent.MSHFlexGrid1)

End Select

End Sub

Function ExportExcelclip(FLex As MSHFlexGrid)

'------------------------------------------------

‘将表中内容复制到剪贴板

'         [Scols]................复制的起始列

'         [Srows]...............   复制的起始行

'         [Ecols]................ 复制的结束列

'        [Erows]............... 复制的结束行

'------------------------------------------------

Screen.MousePointer = 13

'

    Dim Scols, Srows, Ecols, Erows           As Integer

With FLex

    Scols = .Col

    Srows = .Row

    Ecols = .ColSel

    Erows = .RowSel

 

If .ColSel > .Col And .RowSel > .Row Then

    Scols = .Col

    Srows = .Row

    Ecols = .ColSel

    Erows = .RowSel

ElseIf .ColSel < .Col And .RowSel < .Row Then

    Scols = .ColSel

    Srows = .RowSel

    Ecols = .Col

    Erows = .Row

ElseIf .ColSel > .Col And .RowSel < .Row Then

    Scols = .Col

    Srows = .RowSel

    Ecols = .ColSel

    Erows = .Row

ElseIf .ColSel < .Col And .RowSel > .Row Then

    Scols = .ColSel

    Srows = .Row

    Ecols = .Col

    Erows = .RowSel

End If

   

   If .Col = 1 And .Row = 1 Then

   Scols = 0

   Srows = 0

   End If

   

End With

   

   

Dim i, J       As Integer

Dim str     As String

Dim Fileopens     As Boolean

On Error GoTo err

   

 

          str = ""

          If Srows = 0 Then

          For i = Scols To Ecols             '复制表头

              If i = Scols Then

        '      str = str & FLex.TextMatrix(0, i)

              Else

              str = str & Chr(9) & FLex.TextMatrix(0, i)

              End If

          Next

          End If

 

            For J = Srows To Erows

              If J >= 1 Then

              For i = Scols To Ecols

                If i = Scols Then

                Else

                  str = str & Chr(9) & FLex.TextMatrix(J, i)

                End If

              Next

               str = str & vbCrLf

              End If

            Next

        Clipboard.Clear       '   清除剪贴板

        Clipboard.SetText str       ' 将正文放在剪贴板上

Screen.MousePointer = 0

  

   

   err:

    Select Case err.Number

    Case 0

    Case Else

    Screen.MousePointer = 0

        MsgBox err.Description, vbInformation, "复制出错"

        Exit Function

    End Select

End Function

5. 打印MSHFLEXGRID

 

Sub InitPrint()                     ‘初始化打印机

Printer.Orientation = 2            ‘横向为2，纵向为1

Printer.ScaleMode = 6                         ‘以mm为单位

Printer.ScaleLeft = 30               '左边界

Printer.ScaleTop = 30                         ‘上边界

Printer.ScaleHeight = 300         ‘设定高度

Printer.ScaleWidth = 200             ‘设置宽度

End Sub

Sub PrintMSHGrid(FlexGrid As MSHFlexGrid)

InitPrint

FlexGrid.Parent.PrintForm

Printer.EndDoc

End Sub

6. MSHFLEXGRID的输出

Public Sub OutDataToText(FLex As MSHFlexGrid) ‘输出到TXT文本

          Dim s     As String

          Dim i     As Integer

          Dim J     As Integer

          Dim k     As Integer

          Dim strTemp     As String

          Dim Fname As String

          

If FLex.Rows > 2 Then

If FLex.Parent.Name = "WebData" Then Fname = "myfilename-" & WebData.SelNode & ".txt"

 

'检查并创建临时文件夹

Call CheckPath

          On Error Resume Next

          DoEvents

          Dim FileNum     As Integer

          FileNum = FreeFile

          Open App.Path & "/Temp/" & Fname For Output As #FileNum

                  With FLex

                          k = .Rows

                          For i = 0 To k - 1

                                  strTemp = ""

                                  For J = 0 To .Cols - 1

                                          DoEvents

                                          strTemp = strTemp & .TextMatrix(i, J) & ","

                                  Next J

                                  Print #FileNum, Left(strTemp, Len(strTemp) - 1)

                          Next i

                  End With

          Close #FileNum

          MsgBox “保存成功!文件名为" & Fname & vbCrLf & "保存路径为:" & vbCrLf & App.Path & "/Temp"

          Else

          MsgBox "无数据，请检查"

        End If

End Sub

 

Sub ExporToExcel(FLex As MSHFlexGrid) ‘输出到Excel

Dim xlapp As Excel.Application

Dim xlbook As Excel.Workbook

Dim xlsheet As Excel.Worksheet

 

With FLex

If .Rows > 2 Then

If FLex.Parent.Name = "WebData" Then Fname = "Myfilename-" & WebData.SelNode & ".xls"

Call CheckPath

         

Set xlapp = CreateObject("Excel.Application") '创建Excel对象

 

xlapp.Application.Visible = False

On Error Resume Next

Set xlbook = xlapp.Workbooks.Add

 

'设定单元格格式

With xlbook.Worksheets(1)

.Name = Fname

.Range("A1:M1").Font.Color = vbBlue

.Range("A1:M1").Font.Bold = True

Columns("A:M").EntireColumn.AutoFit

End With

 

'开始传输数据

k = 0

         For i = 0 To .Rows - 1

                 For J = 0 To .Cols - 1

                      xlbook.Worksheets(1).Cells(i + 1, J + 1) = .TextMatrix(i, J)

                  Next J

           Next i

          

xlbook.Worksheets(1).Columns("A:M").EntireColumn.AutoFit

xlbook.SaveAs App.Path & "/Temp/" & Fname

xlbook.Application.Quit

Set xlbook = Nothing

 

          MsgBox “保存成功!文件名为" & Fname & vbCrLf & "保存路径为:" & vbCrLf & App.Path & "/Temp"

Else

          MsgBox "无数据，请检查"

   

End If

 

End With

End Sub

 

Sub CheckPath()

          If Dir(App.Path & "/Temp", vbDirectory) = "" Then

          MkDir App.Path & "/Temp"

          End If

End Sub