visual basic还有人用
ADODC数据库。
设置数据库路径：
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\data\devicemanage.mdb;Persist Security Info=False" '设置数据库路径
Adodc1.CommandType = adCmdText '设置记录源
strSQL = Text4.Text + " AND 专业='" + Combo1.Text + "'"
Adodc1.RecordSource = strSQL
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
Set Text1.DataSource = Adodc1
Text1.DataField = "内容简介"
Adodc1.Recordset.AddNew '添加新纪录
Adodc1.Recordset.Delete          '删除记录代码:
Adodc1.Recordset.Update '保存
Adodc1.Refresh '刷新
Adodc1.ConnectionString = " Provider=Microsoft.ACE.OLEDB.12.0;Data Source = " & App.Path & "\data\锅炉参数.accdb;Persist Security Info=False"
Adodc1.CommandType = adCmdText '设置记录源
strSQL = "SELECT * FROM 煤质资料"
Adodc1.RecordSource = strSQL
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
全部条件查询：
Private Sub Command6_Click()
Dim iidd As String
iidd = 0
strSQL0 = "select * from " & " " & Frame1.Caption & " "
If Text2.Text <> "" And Text3.Text <> "" Then
  strSQL0 = strSQL0 + "where (开始时间 >= " + "#" + Text2.Text + "#" + " AND 开始日期<=" + "#" + Text3.Text + "#)"
  iidd = 1
End If
If Text4.Text <> "" And Text5.Text <> "" Then
  If iidd = 1 Then
  strSQL0 = strSQL0 + "and (结束日期 >= " + "#" + Text4.Text + "#" + " AND 结束日期 <=" + "#" + Text5.Text + "#)"
  Else
  strSQL0 = strSQL0 + "where (结束日期 >= " + "#" + Text4.Text + "#" + " AND 结束日期 <=" + "#" + Text5.Text + "#)"
  End If
  iidd = 1
End If
If Text6.Text <> "" Then
  If iidd = 1 Then
  strSQL0 = strSQL0 + "AND 工作内容 LIKE '%" + Text6.Text + "%'"
  Else
  strSQL0 = strSQL0 + "where 工作内容 LIKE '%" + Text6.Text + "%'"
  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 Combo1.Text <> "" Then
Text5.Text = "select * from 现场设备 where 机组='" + Label4.Caption + "'" + " AND 专业='" + Combo1.Text + "'" + " AND 系统='" + DataGrid1.Text + "'" + " And 现场设备名称 Like '%" + Frame6.Caption + "%'"
Frame1.Caption = DataGrid1.Text
fpath = Text2(3).Text
If fpath = "" Then fpath = Text3.Text
Image1.Picture = LoadPicture(fpath)
End If
Frame5.Visible = False
Command11.Caption = "显示系统记事"
End Sub
If MsgBox("请确认是否退出系统?", vbYesNo) = vbYes Then End  ‘退出系统
程序目录：App.Path
由数据库字义菜单：
n1 = Adodc5.Recordset.RecordCount - 1    '定义名称菜单
Text10.DataField = "机组名称"
For n2 = 0 To n1
If n2 > 0 Then Load manupower(n2)
manupower(n2).Caption = Text10.Text
Adodc5.Recordset.MoveNext
Next n2
'移动框架Frame1
Private Sub Frame1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If  Button = 1 Then
        Frame1.Tag = "1"
        x1 = X
        y1 = Y
    End  If
    Frame1.ZOrder 0
End Sub
Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If  Frame1.Tag = "1" Then
        Frame1.Left = Frame1.Left + X - x1
        Frame1.Top = Frame1.Top + 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 Frame1.Tag = ""
End Sub
Private Sub Command8_Click()
If Label4.Caption <> 0 Then
If DataGrid2.Columns(4).Text = "" Then
aaa = Format(CDate(DataGrid2.Columns(1).Text), "yyyy-mm-dd")
dirname = App.Path + "\Documentation\设备档案\" + Frame2.Caption + aaa
deleterec = MsgBox(dirname, vbYesNo, "新建目录")
If deleterec = vbYes Then
MkDir dirname  ＇新建目录
DataGrid2.Columns(4).Text = dirname
End If
Else
fpath = DataGrid2.Columns(4).Text
Shell "C:\WINDOWS\EXPLORER /N," & fpath, vbNormalFocus  ＇打开目录
End If
End If
End Sub
SetWindowPos Me.hwnd, 1, 0, 0, 0, 0, 3  '取消窗体顶置
SetWindowPos Me.hwnd, -2, 0, 0, 0, 0, 3  '取消窗体顶置
SetWindowPos Me.hwnd, -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(Me.hwnd, -1, 0, 0, 0, 0, 3)
'取消窗口在顶层
  'rtn = SetWindowPos(F_V.hwnd, -2, 0, 0, 0, 0, 3)分享给你的朋友吧：i贴吧 新浪微博QQ空间人人网豆瓣MSN
对我有帮助
Dim fs, f, ta
ta = Dir3.Path + "\" + File3.FileName
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(ta)
filetime = f.DateCreated    ＇获取文件创建时间
docuname = File3.FileName
documaddr = Dir3.Path
打开某类型文件： 
If Right(ta, 3) = "dwg" Then Shell "D:\Program Files\AutoCAD " & ta, vbNormalFocus
    If Right(ta, 3) = "jpg" Then Call Shell("C:\WINDOWS\EXPLORER " & ta, vbMaximizedFocus)
    If Right(ta, 3) = "pdf" Then Call Shell("C:\Program Files\Adobe\Reader 9.0\" & 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 Form2.Visible = True Then Call newdocum
End Sub
        用VB动态创建Access数据:
到VB编辑器主窗体的【工程】菜单－>【引用】，在弹出的窗体中选择【Microsoft    ADO    Ext. 2.X for DDL and Security】
          Dim cat As New ADOX.Catalog
            Dim tbl As New ADOX.Table
            Dim pstr As String
            Dim db As String
    
            db = App.Path & "\" & "tmp.mdb"
    
            pstr = "Provider=Microsoft.Jet.OLEDB.4.0;"        '数据库驱动 4.0 For Office 2k/2003, 3.5.1 For Office 97 
    
            pstr = pstr & "Data Source=" & db                         
    
            cat.Create pstr   ＇创建新的ＭＤＢ文件 
            cat.ActiveConnection = pstr
    
            tbl.Name = "Table_One"                                          
    
            tbl.Columns.Append "No", adInteger‘整型
            tbl.Columns.Append "Name", adVarWChar, 20      ‘表头名称，数据类型，字段长
            tbl.Columns.Append "Age", adInteger
tbl.Keys.Append "primarykey", adKeyPrimary, "no", "", ""    '设置主键
            cat.Tables.Append tbl                                            'Create table 1                       
tbl.Columns("工作内容").Attributes = adColNullable  ' 允许为空
    准备创建第二个表格。
            Set tbl = Nothing                                                      'Reset Adox table
    
            Set tbl = New ADOX.Table
    
            tbl.Name = "Table_Two"                                        'Create table 2, Next 3,4,....

            tbl.Columns.Append "No", adInteger
            tbl.Columns.Append "Count", adVarBinary
            tbl.Columns.Append "Time", adDate
    
            cat.Tables.Append 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(list1.hwnd, LB_GETITEMHEIGHT, 0, ByVal 0&)
lstHtemp = CLng(1.2 * lstH)
SendMessage list1.hwnd, LB_SETITEMHEIGHT, 0, ByVal lstHtemp
list1.Refresh
出所有的目录。
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
Command5.Enabled = False
a = 1
n = 1
b = 0
n1 = 1
dirno = 1
Folder(n, a) = App.Path    '父目录
   
'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为第几级目录
                File1.Path = tendir
                Call allfilelist
            End If
        End If
        sPath = Dir '查下一个文件夹
        'DoEvents '让出控制权
       
    Loop
    Next a
    dirno = b
   
    If b <> 0 Then
    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 File1.ListCount <> 0 Then
i1 = File1.ListCount - 1
For i2 = 0 To i1
ta = tendir + "\" + File1.List(i2)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(ta)
'filetime = f.DateCreated
filetime = f.DateLastModified
docuname = File1.List(i2)
documaddr = CStr(tendir)
i = Len(documaddr)
i = i - Len(App.Path)
documaddr = Right(documaddr, i)
Adodc1.Recordset.AddNew '添加新纪录
DataGrid1.Columns(0).Value = filetime
'Adodc1.Recordset(1).Value = Text2.Text
DataGrid1.Columns(2).Value = docuproperty
DataGrid1.Columns(3).Value = docuname
DataGrid1.Columns(5).Value = documaddr
Adodc1.Recordset.Update
Adodc1.Refresh
Next i2
End If
End Sub
Private Sub Command5_Click()    ‘文件复制
Dim fname As String
CommonDialog1.Filter = "缺陷考核 (缺陷考核.xls)|缺陷考核.xls|"
CommonDialog1.ShowOpen
fname = ""
fname = CommonDialog1.FileName
If fname <> "" Then
FileCopy fname, App.Path & "\excel\缺陷考核.xls"
MsgBox ("完成")
Command5.Enabled = False
End If
End Sub
Private Sub Command9_Click()    '导出考核列表EXCEL
Dim xlapp, xlBook, xlSHEET
Dim k, j As Integer
Set xlapp = CreateObject("excel.application")
Set xlBook = xlapp.workbooks.Add
Set xlSHEET = xlBook.worksheets(1)
xlapp.Visible = True
On Error Resume Next
If Err.Number <> 0 Then Set xlapp = CreateObject("Excel.Application")
Set xlBook = xlapp.workbooks.Add
Set xlSHEET = xlBook.ActiveSheet
For k = 1 To DataGrid1.Columns.Count
xlSHEET.Cells(1, k) = DataGrid2.Columns(k - 1).Caption
Next k
For i = 1 To Adodc2.Recordset.RecordCount + 1
For j = 0 To DataGrid2.Columns.Count
xlSHEET.Cells(i + 1, j + 1) = Adodc2.Recordset(j) '
Next j
Adodc2.Recordset.MoveNext
Next i
End Sub
在VB中如何判断文件、文件夹是否存在和生成文件夹
Dir ([PathName],[Attributes as VbFileAttribute = vbNormal]) as String
   解释：PathName:文件或文件夹的绝对路径。
        Attributes:文件的属性--默认值：vbNormal 是普通文件，vbHidden 是隐藏文件，vbDirectory是文件夹。
     "[]"内为可以选项。Dir(file)=""表示文件或文件夹不存，即文件或文件夹的实际路径文空。Dir(file)<>""表示文件或文件夹存在,即文件或文件夹实际路径不为空。 
   例如判断C:\Windows\是否存在，如存在，就调用它，可用下列语句：
   ’文件存，利用Shell调用,默值为vbNormal
If Dir("C:\Windows\")<>"" Then
    Shell "C:\Windows\"
End If     

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。