'=======================================================
'一、如何使用ADODC控件绑定数据到DataGrid和DataList
'=======================================================
Public isDB As Boolean
Private Sub Form_Load()
Dim connStr, AccessLocation As String
AccessLocation = "C:\db1.mdb"
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessLocation & ";Persist Security Info=False"
Adodc1.ConnectionString = connStr
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from tableabc"
Adodc1.Refresh
For i = 0 To Adodc1.Recordset.Fields.Count - 1
List1.AddItem Adodc1.Recordset.Fields(i).Name
Next
Set DataList1.DataSource = Adodc1
DataList1.DataField = "Col1"
DataList1.BoundColumn = "Col1"
Set DataList1.RowSource = Adodc1
DataList1.ListField = "Col1"
Adodc1.Recordset.MoveFirst
End Sub
Private Sub List1_Click() '选择DataGrid中显示的字段
Dim sql, sql1 As String
sql = "select "
For i = 0 To List1.ListCount - 1
If List1.Selected(i) Then
If Trim(sql1) = "" Then
sql1 = List1.List(i)
Else
sql1 = sql1 & ", " & List1.List(i)
End If
End If
Next
If Trim(sql1) = "" Then
sql1 = "*"
End If
sql = sql & sql1 & " from tableabc"
Adodc1.RecordSource = sql
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
End Sub
'========================================================
'二、如何对文件进行二进制读写
'========================================================
Dim getValue() As Byte
Private Sub Command1_Click()
Open "C:\1.cmd" For Binary Access Write As #2
Put #2, , getValue()
Close #2
End Sub
Private Sub Form_Load()
Open "C:\command.com" For Binary Access Read As #1
ReDim getValue(FileLen("C:\command.com"))
Get #1, , getValue
Close #1
End Sub
'========================================================
'三、字符串处理算法(1)
' 求出已知字符串中出现频率最高的字串内容及出现次数
'========================================================
Private Sub Command1_Click()
Dim a, b As String
Dim i As Long
Dim c, t As Long
c = 0
a = "abcdefcdedgcdeethcdenbicde"
For i = 1 To Len(a)
t = 0
b = a
If i = Len(a) - 2 Then Exit For
Do Until InStr(b, Mid(a, i, 3)) = 0
b = Right(b, Len(b) - InStr(b, Mid(a, i, 3)))
t = t + 1
Loop
If t > c Then
c = t
End If
Next
MsgBox c
End Sub
'========================================================
'四、DriveListBox,DirListBox,FileListBox三个控件的使用
'========================================================
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub File1_Click()
Text1.Text = File1.Path & "\" & File1.FileName
End Sub
'========================================================
'五、如何对目录进行操作 (使用FSO)
'========================================================
Private Sub Command1_Click()
Dim fso As Object
Dim SourcePath, TargetPath As String
SourcePath = Text1.Text
TargetPath = Text2.Text
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(TargetPath) Then
fso.CopyFolder SourcePath & "*.*", TargetPath
fso.CopyFile SourcePath & "*.*", TargetPath
Else
fso.CreateFolder (TargetPath)
fso.CopyFolder SourcePath & "*.*", TargetPath
fso.CopyFile SourcePath & "*.*", TargetPath
End If
Set fso = Nothing
MsgBox "复制完成"
End Sub
Private Sub Command2_Click()
Dim fso As Object
Dim TargetPath As String
TargetPath = "D:\Test"
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFolder TargetPath, True
Set fso = Nothing
MsgBox "删除成功"
End Sub
'========================================================
'六、如何取出DataGrid控件选定行的内容
'========================================================
Private Sub DataGrid1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DataGrid1.Row = DataGrid1.RowContaining(Y)
MsgBox DataGrid1.Columns(0).Text
End Sub
Private Sub Form_Load()
Adodc1.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=test;Data Source=SERVER"
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from test"
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
DataGrid1.AllowUpdate = False
End Sub
'========================================================
'七、如何ADODB对象绑定DataGrid控件
'========================================================
Private Sub Form_Load()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
conn.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=test;Data Source=SERVER"
conn.Open , "sa"
rst.CursorLocation = adUseClient
rst.Open "select * from table1", conn, adOpenDynamic, adLockOptimistic
Set DataGrid1.DataSource = rst
End Sub
'========================================================
'八、日期函数的使用以及使用FileExists判断文件是否存在
'========================================================
Private Sub Command1_Click()
If IsNumeric(Text1.Text) And InStr(Text1.Text, ".") = 0 And InStr(Text1.Text, "-") = 0 Then
If CLng(Text1.Text) > 0 And CLng(Text1.Text) <= 12 Then
MsgBox DateDiff("d", DateSerial(Year(Now()), Text1.Text, 1), DateAdd("m", 1, DateSerial(Year(Now()), Text1.Text, 1)))
Else
MsgBox "Error"
End If
Else
MsgBox "Error, Wrong Value"
End If
End Sub
Private Sub Command2_Click()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists("C:\command.com") = True Then
MsgBox "C:\Command.com 文件已存在"
Else
MsgBox "C:\Command.com 文件不存在"
End If
Set fso = Nothing
End Sub
'========================================================
'九、十进制与二进制的简单算法。
'========================================================
Private Sub Command1_Click()
Dim a, b As Long
Dim c As String
a = Text1.Text
Do
If a = 0 Then Exit Do
If a > 1 Then
b = a Mod 2
Else
b = a
End If
c = CStr(b) & CStr(c)
a = a \ 2
Loop
Text2.Text = c
End Sub
Private Sub Command2_Click()
Dim a, b As String
Dim i, c, d As Long
a = Text2.Text
For i = 1 To Len(a)
c = CLng(Mid(a, i, 1))
If c = 1 Then
d = d + 2 ^ (Len(a) - i)
End If
Next
Text3.Text = d
End Sub
'========================================================
'十七、在容器中移动控件
'========================================================
Public isMove As Boolean
Public bX, bY As Long
Private Sub Form_Load()
isMove = False
End Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
isMove = True
bX = X
bY = Y
End If
End Sub
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 And isMove Then
Label1.Move X + Label1.Left - bX, Y + Label1.Top - bY
End If
End Sub
Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
isMove = False
End Sub
'========================================================
'十八、如何在运行程序的时候获得外部参数
'========================================================
Private Sub Form_Load()
Dim ParaArray() As String
Dim GetString As String
Dim I As Long
GetString = Trim(Command())
If InStr(GetString, "/") = 1 Then
If Len(GetString) > 1 Then
GetString = Right(GetString, Len(GetString) - 1)
ParaArray = Split(GetString, "/", -1, vbTextCompare)
For I = 0 To UBound(ParaArray())
MsgBox "Parameter " & I + 1 & ": = " & Trim(ParaArray(I))
Next
Else
MsgBox "Empty Parameter!"
End If
Else
If InStr(GetString, "/") = 0 Then
MsgBox "No Parameter! "
Else
MsgBox "Wrong Format"
End If
End If
End Sub
'========================================================
'十九、注册表的操作
'========================================================
Option Explicit
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Const REG_NONE = 0
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_MULTI_SZ = 7
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Sub Command1_Click()
Dim hKey As Long
Dim DSNName, strDriver, strServer, strDatabase, strLastUser, strDBType As String
DSNName = "myodbc"
strDriver = "C:\\WINNT\\System32\\sqlsrv32.dll" 'SQL Server的驱动,如果用VFP可以改成相应的文件
strServer = "SERVER"
strDatabase = "test"
strLastUser = "sa"
strDBType = "SQL Server"
RegCreateKey HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKey
RegSetValueEx hKey, DSNName, 0, REG_SZ, ByVal strDBType, Len(strDBType) + 1
RegCreateKey HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & DSNName, hKey
RegSetValueEx hKey, "Driver", 0, REG_EXPAND_SZ, ByVal CStr(strDriver), Len(strDriver) + 1
RegSetValueEx hKey, "Server", 0, REG_SZ, ByVal CStr(strServer), Len(strServer) + 1
RegSetValueEx hKey, "Database", 0, REG_SZ, ByVal CStr(strDatabase), Len(strDatabase) + 1
RegSetValueEx hKey, "LastUser", 0, REG_SZ, ByVal CStr(strLastUser), Len(strLastUser) + 1
End Sub
'========================================================
'二十、TreeView的使用，及选中其中指定的节点
'========================================================
Private Sub Command1_Click()
Dim nodeY As Node
For Each nodeY In TreeView1.Nodes
If CStr(Trim(nodeY.Text)) = "ff" Then
nodeY.Selected = True
TreeView1.SetFocus
Exit For
End If
Next
End Sub
Private Sub Form_Load()
Rs1.CommandType = adCmdText
Rs1.RecordSource = "select distinct biao,zu from test order by zu"
Rs1.Refresh
Dim Rs As ADODB.Recordset
Set Rs = Rs1.Recordset
Set nodX = TreeView1.Nodes.Add(, , "r", "报表组 ")
i = 0
Dim TempString As String
Dim TempKey As Long
Do Until Rs.EOF Or Rs.BOF
If TempString = Rs!zu Then
Set nodeX = TreeView1.Nodes.Add("Z" & TempKey, tvwChild, "B" & i, Rs!biao)
Else
Set nodX = TreeView1.Nodes.Add("r", tvwChild, "Z" & i, Rs!zu)
Set nodeX = TreeView1.Nodes.Add("Z" & i, tvwChild, "B" & i, Rs!biao)
TempString = Rs!zu
TempKey = i
End If
Rs.MoveNext
i = i + 1
Loop
End Sub
'========================================================
'二十一、Word对象的使用(查找Word文档中是否包含指定关键字，
'以及在指定位置插入字符串)
'========================================================
Private Sub Command1_Click()
Dim wrdApp As Object
Dim f, fso As Object
Dim filepath As String
Dim Keywords As String
filepath = "c:\words"
Keywords = "abc"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folders = fso.GetFolder(filepath)
I = 0
For Each f In folders.Files
If LCase(Right(f.Name, Len(f.Name) - InStrRev(f.Name, "."))) = "doc" Then
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
wrdApp.Documents.Open FileName:=filepath & "\" & f.Name
If InStr(wrdApp.ActiveDocument.Content.Text, Keywords) <> 0 Then
MsgBox f.Name
End If
wrdApp.Quit
End If
Next
Set wrdApp = Nothing
End Sub
Private Sub Command2_Click()
Dim wrdApp As Object
Dim wrdRows, wrdCols, I As Long
Dim insText As String
wrdRows = 10: wrdCols = 10
insText = "TEST"
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
wrdApp.Documents.Open FileName:="C:\words\1.doc"
For I = 1 To wrdRows
wrdApp.ActiveDocument.Content.insertAfter vbCrLf
Next
wrdApp.ActiveDocument.Content.GoTo What:=3, Which:=2, Count:=wrdRows
wrdApp.ActiveDocument.Content.insertAfter Space(wrdCols) & "PPPPPPPPPPPPP"
wrdApp.ActiveDocument.Save
wrdApp.Quit
Set wrdApp = Nothing
End Sub
