2023年11月23日发(作者:)

Visual Basic 6.0程序代码

ADODC数据库

设置数据库路径:

tionString = "Provider=.4.0;Data Source=" + +

";Persist Security Info=False" '设置数据库路径

dType = adCmdText '设置记录源

strSQL = + " AND 专业='" + + "'"

Source = strSQL

h

Set urce = Adodc1

Set urce = Adodc1

eld = "内容简介"

'添加新纪录

'删除记录代码:

'保存

h '刷新

tionString = " Provider=.12.0;Data Source = " &

& "data锅炉参数.accdb;Persist Security Info=False"

dType = adCmdText '设置记录源

strSQL = "SELECT * FROM 煤质资料"

Source = strSQL

h

Set urce = Adodc1

全部条件查询

Private Sub Command6_Click()

Dim iidd As String

iidd = 0

strSQL0 = "select * from " & " " & n & " "

If <> "" And <> "" Then

strSQL0 = strSQL0 + "where (开始时间 >= " + "#" + + "#" + " AND 开始日期

<=" + "#" + + "#)"

iidd = 1

End If

If <> "" And <> "" Then

If iidd = 1 Then

strSQL0 = strSQL0 + "and (结束日期 >= " + "#" + + "#" + " AND 结束日期 <="

+ "#" + + "#)"

Else

1

Visual Basic 6.0程序代码

strSQL0 = strSQL0 + "where (结束日期 >= " + "#" + + "#" + " AND 结束日期

<=" + "#" + + "#)"

End If

iidd = 1

End If

If <> "" Then

If iidd = 1 Then

strSQL0 = strSQL0 + "AND 工作内容 LIKE '%" + + "%'"

Else

strSQL0 = strSQL0 + "where 工作内容 LIKE '%" + + "%'"

End If

iidd = 1

End If

strSQL = strSQL 0

Call sysrecord(strSQL)

End Sub

Private Sub DataGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer)

If <> "" Then

= "select * from 现场设备 where 机组='" + n + "'" + " AND 专业='"

+ + "'" + " AND 系统='" + + "'" + " And 现场设备名称 Like '%"

+ n + "%'"

n =

fpath = Text2(3).Text

If fpath = "" Then fpath =

e = LoadPicture(fpath)

End If

e = False

n = "显示系统记事"

End Sub

If MsgBox("请确认是否退出系统?", vbYesNo) = vbYes Then End 退出系统

程序目录:

由数据库字义菜单:

n1 = Count - 1 '定义名称菜单

eld = "机组名称"

For n2 = 0 To n1

If n2 > 0 Then Load manupower(n2)

manupower(n2).Caption =

xt

Next n2

'移动框架Frame1

Private Sub Frame1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 1 Then

2

Visual Basic 6.0程序代码

= "1"

x1 = X

y1 = Y

End If

0

End Sub

Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

If = "1" Then

= + X - x1

= + Y - y1

End If

End Sub

Private Sub Frame1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 1 Then = ""

End Sub

Private Sub Command8_Click()

If n <> 0 Then

If s(4).Text = "" Then

aaa = Format(CDate(s(1).Text), "yyyy-mm-dd")

dirname = + "Documentation设备档案" + n + aaa

deleterec = MsgBox(dirname, vbYesNo, "新建目录")

If deleterec = vbYes Then

MkDir dirname '新建目录

s(4).Text = dirname

End If

Else

fpath = s(4).Text

Shell "C:WINDOWSEXPLORER /N," & fpath, vbNormalFocus '打开目录

End If

End If

End Sub

SetWindowPos , 1, 0, 0, 0, 0, 3 '取消窗体顶置

SetWindowPos , -2, 0, 0, 0, 0, 3 '取消窗体顶置

SetWindowPos , -1, 0, 0, 0, 0, 3 '窗体顶置

先建立类模块:

Option Explicit

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)

窗口代码:

Dim rtn

'让窗口在顶层

rtn = SetWindowPos(, -1, 0, 0, 0, 0, 3)

3

Visual Basic 6.0程序代码

'取消窗口在顶层

'rtn = SetWindowPos(F_, -2, 0, 0, 0, 0, 3)分享给你的朋友吧:i贴吧

浪微博腾讯微博QQ空间人人网豆瓣MSN

对我有帮助

Dim fs, f, ta

ta = + "" + me

Set fs = CreateObject("stemObject")

Set f = e(ta)

filetime = eated 获取文件创建时间

docuname = me

documaddr =

打开某类型文件

If Right(ta, 3) = "dwg" Then Shell "D:Program FilesAutoCAD " & ta,

vbNormalFocus

If Right(ta, 3) = "jpg" Then Call Shell("C:WINDOWSEXPLORER " & ta,

vbMaximizedFocus)

If Right(ta, 3) = "pdf" Then Call Shell("C:Program FilesAdobeReader

" & ta, vbMaximizedFocus)

'摁下右键

Private Sub File2_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single,

Y As Single)

If Button = vbRightButton And e = True Then Call newdocum

End Sub

VB动态创建Access数据:

找到VB编辑器主窗体的【工程】菜单->【引用】,在弹出的窗体中选择【Microsoft ADO Ext. 2.X for DDL and

Security

Dim cat As New g

Dim tbl As New

Dim pstr As String

Dim db As String

db = & "" & ""

pstr = "Provider=.4.0;" '数据库驱动 4.0 For Office 2k/2003, 3.5.1 For Office

97

pstr = pstr & "Data Source=" & db

pstr '创建新的MDB文件

Connection = pstr

= "Table_One"

4

Visual Basic 6.0程序代码

"No", adInteger‘整型

"Name", adVarWChar, 20 ‘表头名称,数据类型,字段长

"Age", adInteger

"primarykey", adKeyPrimary, "no", "", "" '设置主键

cat.T tbl 'Create table 1

s("工作内容").Attributes = adColNullable ' 允许为空

准备创建第二个表格。

Set tbl = Nothing 'Reset Adox table

Set tbl = New ADOX.Table

= "Table_Two" 'Create table 2, Next 3,4,....

"No", adInteger

"Count", adVarBinary

"Time", adDate

tbl

改变LIST的行高:

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As

Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Const LB_GETITEMHEIGHT = &H1A1

Const LB_SETITEMHEIGHT = &H1A0

Dim lstH As Long

Dim lstHtemp As Long

lstH = SendMessage(, LB_GETITEMHEIGHT, 0, ByVal 0&)

lstHtemp = CLng(1.2 * lstH)

SendMessage , LB_SETITEMHEIGHT, 0, ByVal lstHtemp

h

找出所有的目录。

Private Sub Command5_Click()

Dim Files() As String '文件路径

Dim Folder(1000, 1000) As String '文件夹路径

Dim mydir As String

Dim a, b, c, n, n1, dirno As Long

Dim sPath, dirsign As String

d = False

a = 1

n = 1

5

Visual Basic 6.0程序代码

b = 0

n1 = 1

dirno = 1

Folder(n, a) = '父目录

'If n1 = 0 Then b = 0

30 For a = 1 To dirno

'If Folder(n, a) <> "" Then '某一级目录的累计第a个不是空的,反回生成文件

mydir = Folder(n, a)

sPath = Dir(mydir & "", vbDirectory) '查找第一个文件夹

Do While sPath <> "" '循环到没有文件夹为止

If Left(sPath, 1) <> "." Then '为了防止重复查找

If GetAttr(mydir & "" & sPath) And vbDirectory Then '如果是文件

夹则。。。。。。

b = b + 1 '该目录下的文件夹数

'ReDim Preserve Folder(0 To b)

Folder(n1 + n, b) = mydir & "" & sPath '将目录和文件夹名称组

合形成新的目录,并存放到数组中

tendir = Folder(n1 + n, b) & "" 'n1 + n为第几级目录

= tendir

Call allfilelist

End If

End If

sPath = Dir '查找下一个文件夹

'DoEvents '让出控制权

Loop

Next a

dirno = b

If b <> 0 Then

Visual Basic 6.0程序代码

b = 0

n = n + 1

GoTo 30

End If

End Sub

Public Sub allfilelist() 'find file name and address to data

Dim i1, i2 As Integer

Dim fs, f, ta

Dim i As String

If unt <> 0 Then

i1 = unt - 1

For i2 = 0 To i1

ta = tendir + "" + (i2)

Set fs = CreateObject("stemObject")

Set f = e(ta)

'filetime = eated

filetime = stModified

docuname = (i2)

documaddr = CStr(tendir)

i = Len(documaddr)

i = i - Len()

documaddr = Right(documaddr, i)

'添加新纪录

s(0).Value = filetime

'set(1).Value =

s(2).Value = docuproperty

s(3).Value = docuname

s(5).Value = documaddr

h

Visual Basic 6.0程序代码

fname = me

If fname <> "" Then

FileCopy fname, & "excel缺陷考核.xls"

MsgBox ("完成")

d = False

End If

End Sub

Private Sub Command9_Click() '导出考核列表EXCEL

Dim xlapp, xlBook, xlSHEET

Dim k, j As Integer

Set xlapp = CreateObject("ation")

Set xlBook =

Set xlSHEET = eets(1)

e = True

On Error Resume Next

If <> 0 Then Set xlapp = CreateObject("ation")

Set xlBook =

Set xlSHEET = Sheet

For k = 1 To

(1, k) = s(k - 1).Caption

Next k

For i = 1 To Count + 1

For j = 0 To

(i + 1, j + 1) = set(j) '

Next j

xt

Next i

End Sub

VB中如何判断文件、文件夹是否存在和生成文件夹

Dir ([PathName],[Attributes as VbFileAttribute = vbNormal]) as String

解释:PathName:文件或文件夹的绝对路径。

Attributes:文件的属性--默认值:vbNormal 是普通文件,vbHidden 是隐藏文件,vbDirectory是文件夹。

"[]"内为可以选项。Dir(file)=""表示文件或文件夹不存,即文件或文件夹的实际路径文空。Dir(file)<>""表示文件或文件夹存在,即文件或文件夹实

际路径不为空。

例如判断C:是否存在,如存在,就调用它,可用下列语句:

文件存,利用Shell调用,默值为vbNormal

If Dir("C:")<>"" Then

Shell "C:"

End If

8

Visual Basic 6.0程序代码

9