分享
 
 
 

想用就用,VB基础代码

王朝vb·作者佚名  2006-12-16
窄屏简体版  字體: |||超大  

'=======================================================

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

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有