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 ＇创建新的ＭＤＢ文件

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页