作者：Cooly
出处：http://search.csdn.net/expert/topic/51/5101/2003/3/20/1555609.htm

'=======================================================
'一、如何使用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


更多请看原贴：http://expert.csdn.net/Expert/topic/1555/1555609.xml?temp=.3376276

评论

您需要登录后才能评论，请 登录 或者 注册