VB-MSHFlexGrid常用的功能代码

前端之家收集整理的这篇文章主要介绍了VB-MSHFlexGrid常用的功能代码前端之家小编觉得挺不错的,现在分享给大家,也给大家做个参考。

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

Sub QueryFromSybasebyCon(Condition)

With QEvent ‘ QEventForm名称

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 ‘Conditionsql查询条件

.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

原文链接:https://www.f2er.com/vb/262000.html

猜你在找的VB相关文章