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 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,Oldwinproc
End Sub
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