常用代码归集

jsgj2023

Sub 读取指定文本文件的前5个字符()
Dim fso  As Scripting.FileSystemObject
Dim mytxt  As Scripting.TextStream
Dim myfile As String
Dim i  As Long
ActiveSheet.Cells.Clear
myfile = ThisWorkbook.Path & "\Adele.txt"
Set fso = New Scripting.FileSystemObject
Set mytxt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
MsgBox "文本文件的前5个字符为:" & mytxt.Read(5)
mytxt.Close
Set mytxt = Nothing
Set fso = Nothing
End Sub

jsgj2023

Sub 读取指定文本文件全部数据()
    Dim fso As Scripting.FileSystemObject
    Dim myTxt As Scripting.TextStream
    Dim myfile As String
    Dim i As Long
    ActiveSheet.Cells.Clear
    myfile = ThisWorkbook.Path & "\Adele.txt"
    Set fso = New Scripting.FileSystemObject
    Set myTxt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
    Debug.Print myTxt.ReadAll
    myTxt.Close
    Set myTxt = Nothing
    Set fso = Nothing
End Sub

jsgj2023

Sub 创建数据库()
Dim mydatabase As DAO.Database
Dim mydatatable As DAO.TableDef
Dim mydatabasename As String
Dim mydatatablename As String
mydatabasename = ThisWorkbook.Path & "\销售管理.mdb"
mydatatablename = "销售明细"
On Error Resume Next
Kill mydatabasename
On Error GoTo 0
Set mydatabase = CreateDatabase(mydatabasename, dbLangGeneral)
Set mydatatable = mydatabase.CreateTableDef(mydatatablename)
With mydatatable
    .Fields.Append .CreateField("客户编号", dbText, 10)
     .Fields.Append .CreateField("客户名称", dbText, 30)
      .Fields.Append .CreateField("联系地址", dbText, 50)
       .Fields.Append .CreateField("联系电话", dbText, 20)
        .Fields.Append .CreateField("联系人", dbText, 10)
         .Fields.Append .CreateField("Email", dbText, 50)
End With
mydatabase.TableDefs.Append mydatatable
Set mydatabase = Nothing
MsgBox "创建数据库成功!" & vbCrLf _
& "数据库文件名为:" & mydatabasename & vbCrLf _
& "数据表名称为:" & mydatatablename & vbCrLf _
& "保存位置:当前工作簿所在的文件夹.", vbOKOnly + vbInformation, "创建数据库"
End Sub

jsgj2023

Sub 删除指定数据库中的数据表()
Dim mydata As String
Dim mytable As String
Dim sql As String
Dim cnn  As ADODB.Connection
Dim rs  As ADODB.Recordset
mydata = ThisWorkbook.Path & "\职工管理.mdb"
mytable = "职工信息备份"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
sql = "drop table " & mytable
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
MsgBox "已经成功将数据表<职工信息备份>删除"
cnn.Close
Set rs = Nothing
Set cnn = Nothing

jsgj2023

Sub 查找指定的数据表是否存在()
Dim mydata As String
Dim mytable As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
mydata = ThisWorkbook.Path & "\客户管理.mdb"
mytable = "客户信息"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
Set rs = cnn.OpenSchema(adSchemaTables)
Do Until rs.EOF
    If LCase(rs!table_name) = LCase(mytable) Then
        MsgBox "数据表<" & mytable & "> 存在!"
        GoTo 1000
    End If
    rs.MoveNext
Loop
MsgBox "数据表" & mytable & "不存在!"
1000:
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

jsgj2023

Sub 读取数据库的数据表名称()
Dim mydata  As String
Dim mycat As New ADOX.Catalog
mydata = ThisWorkbook.Path & "\客户管理.mdb"
mycat.ActiveConnection = "provider=microsoft.jet.oledb.4.0;" & "data source=" & mydata
msgb = ""
k = 1
For i = 0 To mycat.Tables.Count - 1
    If Left(mycat.Tables.Item(i).Name, 4) <> "MSys" Then
        ActiveSheet.Cells(k, 1) = mycat.Tables.Item(i).Name
        k = k + 1
    End If
Next
Set mycat.ActiveConnection = Nothing
End Sub

jsgj2023

Sub 检测数据库中是否存在指定的字段()
Dim mydata As String
Dim mytable As String
Dim mycolumn  As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
mydata = ThisWorkbook.Path & "\客户管理.mdb"
mytable = "客户资料"
mycolumn = "客户名称"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
Set rs = cnn.OpenSchema(adSchemaColumns)
Do Until rs.EOF
    If LCase(rs!column_name) = LCase(mycolumn) Then
        MsgBox "在数据表" & mytable & "中存在字段<" & mycolumn & ">! "
        GoTo 1000
    End If
    rs.MoveNext
Loop
MsgBox "在数据表" & mytable & "中不存在字段 " & mycolumn & "!"
1000:
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

jsgj2023

Sub 获取指定数据表的字段名称_类型_大小()
Dim mydata As String
Dim mytable As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim myfield  As ADODB.Field
Dim fieldtype  As String
Dim fieldlong As Integer
mydata = ThisWorkbook.Path & "\客户管理.mdb"
mytable = "客户信息"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
Set rs = New ADODB.Recordset
rs.Open mytable, cnn, adOpenKeyset, adLockOptimistic
With ActiveSheet
.Cells.Clear
.Range("a1:c1") = Array("字典名称", "字段类型", "字段大小")
k = 2
For Each myfield In rs.Fields
    .Range("a" & k) = myfield.Name
    .Range("b" & k) = myfield.Type
    .Range("c" & k) = myfield.DefinedSize
    k = k + 1
Next
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
End With
End Sub

jsgj2023

Sub 输出指定数据表的字段名称_类型_大小()
Dim mydata As String
Dim mytable As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim myfield As ADODB.Field
Dim fieldtype  As String
Dim fieldlong As Integer
mydata = ThisWorkbook.Path & "\客户管理.mdb"
mytable = "客户信息"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
Set rs = New ADODB.Recordset
rs.Open mytable, cnn, adOpenKeyset, adLockOptimistic
With ActiveSheet
    .Cells.Clear
    .Range("a1:c1") = Array("字段名称", "字典类型", "字段大小")
    k = 2
    For Each myfield In rs.Fields
        .Range("a" & k) = myfield.Name
        .Range("b" & k) = IntegerToVBAConstant(myfield.Type)
        .Range("c" & k) = myfield.DefinedSize
        k = k + 1
    Next
    rs.Close: cnn.Close
    Set rs = Nothing: Set cnn = Nothing
End With
End Sub

jsgj2023

Sub 提取指定数据表的数据()
Dim mydata As String
Dim mytable As String
Dim sql As String
Dim cnn As ADODB.Connection
Dim rs  As ADODB.Recordset
Dim i  As Integer
ActiveSheet.Cells.Clear
mydata = ThisWorkbook.Path & "\成绩管理.mdb"
mytable = "考试成绩"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
sql = "select * from " & mytable
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
For i = 1 To rs.Fields.Count
    Cells(1, i) = rs.Fields(i - 1).Name
Next i
With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
End With
Range("a2").CopyFromRecordset rs
With ActiveSheet
    .Columns(rs.Fields.Count).NumberFormat = "yyyy-mm-dd"
    .Columns.AutoFit
End With
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
End Sub