在 VB6 中操作 EXCEL 过程中, 如何避免用户操作鼠标千万的影响

eisldkw 2020-07-07 11:04:12
在 VB6 中操作 EXCEL , 在操作过程中,如果用户在EXCEL中点击了鼠标,会对操作千万不确定的影响,相关代码如下,怎么做才能在VB6操作EXCEL的过程中,用户移动或点击鼠标 ,对下面的代码不会产生影响,操作完后,再把控件权交给用户。


Dim Rs_Data As New AdoDB.Recordset
Dim Irowcount As Long
Dim Icolcount As Long
' Dim xlApp As New Excel.Application
' Dim xlBook As Excel.Workbook
' Dim xlSheet As Excel.Worksheet
' Dim xlQuery As Excel.QueryTable


' Dim ExApp As Object
On Error Resume Next
Set ExApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
Set ExApp = CreateObject("Excel.Application")
If Err.Number <> 0 Then
Err.Clear
MsgBox "本机上未安装EXCEL,请先安装后再运行本程序!", vbInformation
Else
'MsgBox "您的电脑中已安装Word程序!", vbInformation
ExApp.quit
End If
Else
' MsgBox "e已启动,请先退出后再运行本程序!", vbInformation
End If

On Error GoTo Errc

' Dim xlApp As Object
' Dim xlBook As Object
' Dim xlSheet As Object
' Dim xlQuery As Object


With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Conn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = SQLofBB4 ' strOpen
.Open
End With

With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Sub
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With

Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")


' Application对象
' Workbook对象
' Worksheet对象
' Range对象


xlApp.Visible = True

'添加查询语句,导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = 1 ' xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With

xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh

With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Size = 10
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = 1 ' xlContinuous


'设表格边框样式
End With
' xlSheet.RANGE(.Cells(4, 4)).End(xlDown).offset(3, 0).value = " 死毕哥 "
With xlSheet.pagesetup
.Orientation = 2 'xlLandscape
End With


I = 2

Dim lngFirstRow As Long
Dim blnInit As Boolean
blnInit = False

Dim lngMaxRow As Long

lngMaxRow = xlSheet.Range("A3").End(-4121).Row
lngMaxRow = xlSheet.Range("A1").End(-4121).Row ' 2019-12-11


'**************************************************************************************************

' Dim objRange As Object
' Set objRange = xlSheet.Range(strRange)
'
' Dim strData As String
' strData = objRange.Item(1, 1)
'
' objRange.Clear
' objRange.Merge
' objRange.value = strData

Dim objRange As Object
Dim strData As String

' Set objRange = xlSheet.Range(strRange)
' strData = objRange.Item(1, 1)
'
' objRange.Clear
' objRange.Merge
' objRange.value = strData


Dim j As Long

Dim A As Long, B As Boolean, Index As Long, C As String

' A = xlSheet.Range("R" & "2")

A = xlSheet.Range("S" & "2")

C = A
B = False 'b 相同时为FALSE 不同时为TRUE

Index = 0

For I = 1 To lngMaxRow

If I = 1 Then '1如果为第一条记录不处理

Index = 1

Else '1如果为第一条之后的记录

'If A = xlSheet.Range("R" & CStr(1 + I)) Then '2 如果相同 则 INDEX加1

If A = xlSheet.Range("S" & CStr(1 + I)) Then '2 如果相同 则 INDEX加1

Index = Index + 1

Else '2 如果不相同 则

If Index > 1 Then

strRange = "P" & I - Index + 1 & ":P" & I
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)

objRange.Clear
objRange.Merge
objRange.value = strData

strRange = "Q" & I - Index + 1 & ":Q" & I
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)

objRange.Clear
objRange.Merge
objRange.value = strData


strRange = "R" & I - Index + 1 & ":R" & I
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)

objRange.Clear
objRange.Merge
objRange.value = strData

strRange = "T" & I - Index + 1 & ":T" & I
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)

objRange.Clear
objRange.Merge
objRange.value = strData



End If
Index = 1
A = xlSheet.Range("S" & CStr(1 + I))

End If

End If

' C = xlSheet.Range("R" & CStr(1 + I + 1))
C = xlSheet.Range("S" & CStr(1 + I + 1))
If C = "" Then

If Index > 1 Then

strRange = "P" & (I - Index + 2 & ":P" & I + 1)
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)

objRange.Clear
objRange.Merge
objRange.value = strData

strRange = "Q" & (I - Index + 2 & ":Q" & I + 1)
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)

objRange.Clear
objRange.Merge
objRange.value = strData

'strRange = "S" & (I - Index + 2 & ":S" & I + 1)
strRange = "R" & (I - Index + 2 & ":R" & I + 1)
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)

objRange.Clear
objRange.Merge
objRange.value = strData

strRange = "T" & (I - Index + 2 & ":T" & I + 1)
Set objRange = xlSheet.Range(strRange)
strData = objRange.Item(1, 1)

objRange.Clear
objRange.Merge
objRange.value = strData

End If

End If

Next I

'******************************************************************************************************
...全文
188 1 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
1 条回复
切换为时间正序
请发表友善的回复…
发表回复
ypk9999 2020-07-07
  • 打赏
  • 举报
回复
你这写法看起来部会受到影响,如果你有用如 ActiveSheet,很容易被使用者操作干扰 另一个办法是一开始用 excelapp.visible = FALSE 把 excel 视窗隐藏起来 最后在设 excelapp.visible = TRUE 显示出来

7,785

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧