想用就用，VB基礎程式碼 (轉)

想用就用，VB基礎程式碼 (轉)[@more@]

作者：/Message_Board/Send.?sendto=Cooly" target=_blank>Cooly
出處：/3/20/1555609.htm">

'=======================================================
'一、如何使用ADODC繫結資料到DataGrid和DataList
'=======================================================

Public is As Boolean

Private Sub Form_Load()
Dim connStr, Acceocation As String
AccessLocation = "C:db1.mdb"
connStr = "Provr=.Jet.OLEDB.4.0;Data =" & AccessLocation & ";Persist Security Info=False"
Adodc1.ConnectionString = connStr
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = " * 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 , 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
  L
  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

'========================================================
'五、如何對目錄進行操作 (使用)
'========================================================

Private Sub Command1_Click()
Dim fso As
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.檔案已存在"
  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_ = &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_D = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_MULTI_SZ = 7

Private Declare Function RegSetValueEx Lib "adv32.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, str, strServer, strDatabase, strLastUser, strDBType As String

DSNName = "myodbc"

strDriver = "C:WINNTSystem32sqlsrv32.dll" '的,如果用VFP可以改成相應的檔案
strServer = "SERVER"
strDatabase = "test"
strLastUser = "sa"
strDBType = "SQL Server"

RegCreateKey HKEY_LOCAL_MACHINE, "SOFTWAREODBCODBC.INIODBC Data Sources", hKey
RegSetValueEx hKey, DSNName, 0, REG_SZ, ByVal strDBType, Len(strDBType) + 1

RegCreateKey HKEY_LOCAL_MACHINE, "SOFTWAREODBCODBC.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:words1.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


更多請看原貼：?temp=.3376276">