在 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

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

...全文