敲了一天的代码,上上上!!!
'限制特殊字符和字母
Private Sub txtCardNumber_KeyPress(KeyAscii As Integer)
Dim cTemp As String
cTemp = "`~!@#$%^&*()-=_+[]{};:'\|<>/?.‘“”’、,。——+()《》?,~·……¥!:;【】" & """ '禁止输入特殊的字符"
If InStr(1, cTemp, Chr(KeyAscii)) <> 0 Then
KeyAscii = 0
End If
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then
Else
KeyAscii = 0
MsgBox "只能输入数字", vbOKCancel + vbExclamation, "提示"
txtCardNumber.Text = ""
End If
End Sub
Private Sub cmdOk_Click()
Dim mrc As ADODB.Recordset
Dim MsgText As String
Dim txtSQL As String
txtSQL = "select * from Line_Info where cardno ='" & txtCardNumber.Text & "'"
Set mrc = ExecuteSQL(txtSQL, MsgText)
If Trim(txtCardNumber.Text = "") Then
MsgBox "卡号为空,请输入卡号!", vbOKOnly + vbExclamation, "警告"
txtCardNumber.SetFocus
End If
MSshow.Clear
With MSshow
.Rows = 1
.TextMatrix(0, 0) = "卡号"
.TextMatrix(0, 1) = "姓名"
.TextMatrix(0, 2) = "上机日期"
.TextMatrix(0, 3) = "上机时间"
.TextMatrix(0, 4) = "下机日期"
.TextMatrix(0, 5) = "下机时间"
.TextMatrix(0, 6) = "消费金额"
.TextMatrix(0, 7) = "余额"
.TextMatrix(0, 8) = "备注"
End With
'判断是否存在收取金额记录
If mrc.EOF = True Then
MsgBox "没有上机记录!", vbOKOnly + vbInformation, "提示"
Exit Sub
Else
With MSshow
'判断是否移动到数据集对象的最后一条记录
Do While mrc.EOF = False
.Rows = .Rows + 1
.CellAlignment = 4
.TextMatrix(.Rows - 1, 0) = Trim(mrc.Fields(1))
.TextMatrix(.Rows - 1, 1) = Trim(mrc.Fields(3))
.TextMatrix(.Rows - 1, 2) = Trim(mrc.Fields(6))
.TextMatrix(.Rows - 1, 3) = Trim(mrc.Fields(7))
.TextMatrix(.Rows - 1, 4) = Trim(mrc.Fields(8))
.TextMatrix(.Rows - 1, 5) = Trim(mrc.Fields(9))
.TextMatrix(.Rows - 1, 6) = Trim(mrc.Fields(11))
.TextMatrix(.Rows - 1, 7) = Trim(mrc.Fields(12))
.TextMatrix(.Rows - 1, 8) = Trim(mrc.Fields(13))
'移动到下一条记录
mrc.MoveNext
Loop
mrc.Close
End With
End If
End Sub
Private Sub cmdExport_Click()
'新建一个Excel文件
Dim xlAPP As Object
Dim xlBook As Object
Dim xSheet As Object
'导出Excel文件
Dim i As Long
Dim j As Integer
On Error GoTo err_proc
'创建一个电子表格
Set xlAPP = CreateObject("Excel.application")
'创建一个工作簿文件
Set xlBook = xlAPP.workbooks.Add
'创建一个Sheet表
Set xSheet = xlBook.worksheets(1)
With MSshow
'读取所有行
For i = 0 To .Rows - 1
'读取所有列
For j = 0 To .Cols - 1
xSheet.cells(i + 1, j + 1).Value = .TextMatrix(i, j)
Next j
Next i
End With
'使Excel表可见
xlAPP.Visible = True
Exit Sub
err_proc:
Screen.MousePointer = vbDefault
MsgBox "请确认您的电脑安装了Excel!", vbOKCancel + vbQuestion, "提示"
End Sub