''============================================= ''名称: FindPath ''作用: 查找指定文件夹下面的所有文件和其子目录下的文件 ''参数：strPath 要查找的目录， '' strFiles 用于存查找结果的缓冲区，String 类型的动态数组，调用时事先初始化， 如Redim strFiles(0) '' FileCount 用于返回文件个数 ''============================================= Public Sub FindPath(ByVal strPath As String, strFiles() As String, FileCount As Long) Dim strDirs() As String Dim strResult As String Dim FileLimit As Long Dim dirLimit As Long Dim dirCount As Long Dim I As Long
FileLimit = UBound(strFiles) + 1 dirLimit = 0 If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" strResult = Dir(strPath, vbDirectory + vbSystem + vbReadOnly + vbHidden + vbNormal + vbArchive) Do While Len(strResult) > 0 If strResult <> "." And strResult <> ".." Then If (GetAttr(strPath & strResult) And vbDirectory) <> vbDirectory Then If FileCount >= FileLimit Then ReDim Preserve strFiles(FileLimit + 10) FileLimit = FileLimit + 10 End If strFiles(FileCount) = strPath & strResult FileCount = FileCount + 1 Else If dirCount >= dirLimit Then ReDim Preserve strDirs(dirLimit + 10) dirLimit = dirLimit + 10 End If strDirs(dirCount) = strPath & strResult dirCount = dirCount + 1 End If End If strResult = Dir(, vbDirectory + vbSystem + vbReadOnly + vbHidden + vbNormal + vbArchive) Loop
For I = 0 To dirCount - 1 Call FindPath(strDirs(I), strFiles, FileCount) Next I End Sub Top
从VB将数据导出到EXCEL,网上可能有很多这样的代码,但是前提都要安装EXCEL,今天我分享给大家的就是没有安装EXCEL的一样也可以导出. Rem 作者:谢炎锦 创建时间:2002-12-20 Mail:XieYanJin@163.Com Rem 内容如下: Rem 引用方式: Export(Ado.Recordset) 或 Export(Rds.RecordSet) Rem 支持 Rds 与 Ado 的记录导出 Rem 得到所有数据类型,有些数据类型EXCEL不支持,已经替换掉
Public Function FieldType(intType) Select Case intType Case 20 FieldType = "int" Case 128 FieldType = "binary" Case 11 FieldType = "bit" Case 129 FieldType = "char" Case 135 FieldType = "datetime" Case 131 FieldType = "varchar" Case 5 FieldType = "float" Case 205 FieldType = "image" Case 3 FieldType = "int" Case 6 FieldType = "money" Case 130 FieldType = "char" Case 203 FieldType = "text" Case 131 FieldType = "numeric" Case 202 FieldType = "varchar" Case 4 FieldType = "real" Case 135 FieldType = "datetime" Case 2 FieldType = "int" Case 6 FieldType = "money" Case 204 FieldType = "varchar" Case 201 FieldType = "text" Case 128 FieldType = "timestamp" Case 17 FieldType = "varchar" Case 72 FieldType = "varchar" Case 204 FieldType = "varbinary" Case 200 FieldType = "varchar" End Select End Function Public Sub ExportToExcel(AdoRecordSet As ADODB.Recordset) On Error GoTo Excel_Err Dim Excel_Dsn As String Dim Excel_Conn As New ADODB.Connection Dim Excel_Adodc As New ADODB.Recordset Dim mySql As String Dim i, j, TmpField, FileName Rem 得到文件名 For i = 0 To 100 If Len(i) = 1 Then FileName = "C:\Query_0" & i Else FileName = "C:\Query_" & i End If If Dir(FileName & ".xls", vbHidden) = "" Then Exit For End If Next FileName = FileName & ".xls" Excel_Dsn = "DRIVER={Microsoft Excel Driver (*.xls)};DSN='';FIRSTROWHASNAMES=1;READONLY=FALSE;CREATE_DB=""" & FileName & """;DBQ=" & FileName Excel_Conn.Open Excel_Dsn With AdoRecordSet If Not (.EOF And .BOF) Then mySql = "Create Table [Query] (" For i = 0 To .Fields.Count - 1 TmpField = FieldType(.Fields(i).Type) If TmpField = "char" Or TmpField = "varchar" Or TmpField = "nchar" Or TmpField = "nvarchar" Or TmpField = "varbinary" Then If .Fields(i).DefinedSize >= 256 Then mySql = mySql & Trim(.Fields(i).Name) & " text," Else mySql = mySql & Trim(.Fields(i).Name) & " " & FieldType(.Fields(i).Type) & "(" & .Fields(i).DefinedSize & ")" & "," End If ElseIf TmpField <> "image" Then mySql = mySql & Trim(.Fields(i).Name) & " " & FieldType(.Fields(i).Type) & "," End If Next mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1) mySql = mySql & ")" Rem 创建表名 Excel_Adodc.Open mySql, Excel_Dsn, adOpenDynamic, adLockPessimistic Rem 插入数据 For i = 0 To .RecordCount - 1 mySql = "Insert into [Query] Values(" For j = 0 To .Fields.Count - 1 TmpField = FieldType(.Fields(j).Type) Rem Image 不作保存 If TmpField <> "image" Then If IsNull(.Fields(j).Value) Then mySql = mySql & "NULL," Else mySql = mySql & "'" & .Fields(j).Value & "'," End If End If Next mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1) mySql = mySql & ")" Excel_Adodc.Open mySql, Excel_Dsn, adOpenDynamic, adLockPessimistic .MoveNext Next MsgBox "系统提示:" & Chr(13) & " 已经将文件保存到 [ " & FileName & " ]", 64, "系统信息:" End If End With Excel_Conn.Close Set Excel_Conn = Nothing Set Excel_Adodc = Nothing Exit Sub Excel_Err: MsgBox "发生错误:" & Err.Description & Chr(13) & "错误代码:" & Err.Number, 64, "系统信息:"End Sub
