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
@H_502_272@Public Const GWL_WNDPROC = (-4) @H_502_272@Public Const WM_COMMAND = &H111 @H_502_272@Public Const WM_MBUTTONDOWN = &H207 @H_502_272@Public Const WM_MBUTTONUP = &H208 @H_502_272@Public Const WM_MOUSEWHEEL = &H20A @H_502_272@Public Oldwinproc As Long @H_502_272@Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long,_ @H_502_272@ ByVal nIndex As Long,ByVal dwNewLong As Long) As Long @H_502_272@ @H_502_272@Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long,_ @H_502_272@ByVal hwnd As Long,ByVal Msg As Long,ByVal wParam As Long,ByVal lParam As Long) As Long @H_502_272@ @H_502_272@Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long,_ @H_502_272@ ByVal nIndex As Long) As Long @H_502_272@ @H_502_272@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 @H_502_272@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)
@H_502_272@Dim X As Long @H_502_272@Dim Y As Long @H_502_272@Dim L As Long @H_502_272@Dim Tmp As String @H_502_272@X = MSHFlexGrid1.Col @H_502_272@Y = MSHFlexGrid1.Row @H_502_272@Select Case KeyCode '功能或扩展 @H_502_272@ Case 46 ‘响应删除Delete键 @H_502_272@ MSHFlexGrid1.Text = "" @H_502_272@Case vbKeyC '响应Ctrl+C 复制功能 @H_502_272@ Clipboard.Clear @H_502_272@ Call ExportExcelclip(QEvent.MSHFlexGrid1) @H_502_272@End SelectEnd 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