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 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
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 （编辑：李大同） 【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容! |