FROM:编程爱好者BLOG
剪贴板相关===========================================================
'全选
Private Sub mnuSelectAll_Click()
RichTextBox1.SelStart = 0
RichTextBox1.SelLength = Len(RichTextBox1.Text)
End Sub
'粘贴
Private Sub mnuPaste_Click()
RichTextBox1.SelText = Clipboard.GetText
End Sub
'查找
Private Sub mnuFind_Click()
sFind = InputBox("请输入要查找的字、词：", "查找内容", sFind)
RichTextBox1.Find sFind
End Sub
'继续查找
Private Sub mnuFindOn_Click()
RichTextBox1.SelStart = RichTextBox1.SelStart + RichTextBox1.SelLength + 1
RichTextBox1.Find sFind, , Len(RichTextBox1)
End Sub
TextBox操作==========================================================
1、限制只能输入数字
参考下列程序：
Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < 48 Or KeyAscii > 57 Then
KeyAscii = 0
End If
End Sub
2、屏蔽特定字符
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim sTemplate As String
sTemplate = "!@#$%^&*()_+-=" '用来存放不接受的字符
If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then
KeyAscii = 0
End If
End Sub
识别鼠标两键同时按下=================================================
Dim OneDown As Double
Dim ToDown As Integer
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ToDown = 0
If OneDown + 0.1 < Timer Then
OneDown = Timer
Do While OneDown + 0.1 > Timer
DoEvents
If ToDown <> 0 Then Exit Do
Loop
If ToDown <> 0 Then
Print ToDown + Button
Else
Print Button
End If
Else
ToDown = Button
End If
End Sub
消息框中按钮之定义===================================================
MsgBox strMsg1, c1+c2+c3 , strMsg2
其中 strMsg1 为提示信息
strMsg2 为标题内容
c1+c2+c3 定义按钮形式，具体如下：
c1: 按钮的类型
0 vbOkOnly 只有一个按钮“确定”
1 vbOkCancel 两个按钮“确定”和“取消”
2 vbAbortRetryIgnore 三个按钮“终止”、“重试”和“忽略”
3 vbYesNoCancel 三个按钮“是”、“否”和“取消”
4 vbYesNo 两个按钮“是”和“否”
5 vbRetryCancel 两个按钮“重试”和“取消”
返回值： vbOk 1 确定
vbCancel 2 取消
vbAbort 3 终止
vbRetry 4 重试
vbIgnore 5 忽略
vbYes 6 是
vbNo 7 否
c2: 图标的类型
16 vbCritical ×
32 vbQuesion ？
48 vbExclamation ！
64 vbInformation i
c3: 默认焦点
0 vbDefalaultButton1 左起第一个按钮自动获得焦点
256 vbDefalaultButton2 左起第二个按钮自动获得焦点
512 vbDefalaultButton3 左起第三个按钮自动获得焦点
和为： 00 0000 0000 B
c3 c2 c1
例： 1. i = MsgBox " 是否要删除该条记录 ? ", 1+32+0 , " 请确认"
2. MsgBox " 是否要删除 ! ", 0+32+0 , " 请...."
数据库===============================================================
1)判断表的存在
Function M_fucScanTable(strTName As String) As Integer ' 搜索表 strTableName
On Error GoTo OpenErr
Set MyRsm = New Recordset
MyRsm.Open "Select * From " & strTName,Cn, adOpenKeyset, adLockOptimistic
MyRsm.MoveLast
M_fucScanTable = MyRsm.RecordCount ' 返回记录数，0 为空表
MyRsm.Close
Set MyRsm = Nothin
Exit Function
OpenErr:
M_fucScanTable = -1 ' 无表
End Function
2)动态建立表
strSQL = "CREATE TABLE " & strTName & _
"( Xh char(3) Not Null Primary key,Mc char(10),Xb char(2)," & _
"Csrq char(10),Zw char(20),Gz numeric(9,2),Bz char(30),Xp image )"
cn.Execute strSQL, , adCmdText
其中： Primary key 为设置主键（唯一）
3)插入记录 Insert
strSQL = "Insert Into A01(Xh,Mc,Xb,Csrq,Zw) " & _
"Values ( '" & Xhp & "','" & Mcp & "','" & Xbp &"','" &Rqp& "','" & Zwp & "' "
Cn.Execute strSQL
4)导出表格到excel
Dim newxls As Excel.Application
Dim newbook As Excel.Workbook
Dim newsheet As Excel.Worksheet
Set newxls = CreateObject("excel.application")
newxls.Visible = True
Set newbook = newxls.Workbooks.Add
Set newsheet = newbook.Worksheets(1)
For i = 0 To 7
For j = 0 To 4
MSFlexGrid1.Row = i
MSFlexGrid1.col = j
newsheet.Cells(1, 3) = Trim(Combo1.Text) & "班"
newsheet.Cells(1, 4) = "第" & bytXq & "学期"
newsheet.Cells(1, 5) = "课程表"
newsheet.Cells(i + 3, j + 2) = Trim(MSFlexGrid1.TextMatrix(i, j))
Next j
Next i
注意此项操作你先要 引用 excelctl type library 和 microsoft excel 9.0 object library
隐藏任务栏===========================================================
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Sub Form_Load()
SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3
End Sub
获取CPU信息的方法
引用Microsoft WMI Scripting V1.2 Library
Private Function GetProcessorID()
Dim A1 As SWbemServices
Dim A2 As SWbemObjectSet
Dim A3 As SWbemObject
Dim A4 As SWbemPropertySet
Dim A5 As SWbemProperty
Set A1 = GetObject("winmgmts:")
Set A2 = A1.InstancesOf("Win32_Processor")
For Each A3 In A2
With A3
If .Properties_.Count > 0 Then
Set A4 = .Properties_
For Each A5 In A4
'A5.Name为信息名称
'A5.Value为信息值
'如果只获取CpuID可以不修改一下代码，否则可以创建一个Text,改为多行文本来接收A5.Name和A5.Value的信息。
'text1.text = A5.Name & ":" & A5.Value
If InStr(StrConv(A5.Name, 2), "processorid") <> 0 Then
GetProcessorID = A5.Value
End If
Next
End If
End With
Next
End Function
一个实现Winsock直接获得返回数据的函数================================
主要应用：有时候不希望Winsock的数据收发独立，即希望发送数据直接获得结果。这个函数正实现了这一功能
备注:
1、带有“*”的部分已经被省略，主要功能是激活一个进度条用来监视等待数据下载的时间
2、这个函数需要两个事件协作完成
1)KeyPass事件，用来确定是否按下Esc终止等待
2)DataArrival事件，用来确定是否传回数据
函数使用方法:
SendData 数据,[是否立即获取数据],[*是否前台执行],[超时时间]
[]为可选参数
Dim Ws as Winsock
Dim DbInfo As String
Public KeyPassEsc As Boolean ''是否按下Esc，传输进度条用
Public Function SendData(Db As String, Optional GetDb As Boolean = True, Optional FormTop As Boolean = True, Optional EndTime As Integer = 10) As String
''发送数据函数
Dim ToTime As Double ''定义连接超时时间
ToTime = Timer + EndTime
''初始化终止开关
DbGetOk = False
KeyPassEsc = False
Ws.SendData Db ''''发送数据
Do While ToTime > Timer ''''侦听接收情况
DoEvents
If GetDb = False Or DbGetOk Or KeyPassEsc Then
Exit Do
End If
Loop
If DbGetOk Then
SendData = DbInfo
ElseIf GetDb Then
SendData = "获得数据超时，请尝试重新执行程序！"
End If
End Function
Private Sub WS_DataArrival(ByVal bytesTotal As Long) ''当新数据到达时出现
Ws.GetData DbInfo, vbString
DbGetOk = True
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer) ''是否按下Esc
If KeyAscii = 27 Then KeyPassEsc = True
End Sub |