利用Excel VBA SQL做特殊文件浏览器

1、利用JamShellBrowser for ActiveX

 

 
 
'转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/104.html  
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Private Const GWL_STYLE = (-16)  
Private Const WS_THICKFRAME As Long = &H40000 '(恢复大小)  
Private Const WS_MINIMIZEBOX As Long = &H20000 '(最小化)  
Private Const WS_MAXIMIZEBOX As Long = &H10000 '(最大化)  
 
 
Private Sub JamShellList1_OnAddItem(ByVal ItemFullPath As String, CanAdd As Boolean)  
Dim i As Integer 
'Dim rg As Range  
'Dim ws As Worksheet  
'bk = Me.JamShellList1.GetFullPath(Item) '=ItemFullPath  
xx = Right(ItemFullPath, Len(ItemFullPath) - InStrRev(ItemFullPath, "\")) 'ItemFullPath字符串\后的  
If InStr(xx, ".") Then 
    xx = Left(xx, InStr(xx, ".") - 1)  
End If 
'Set ws = ThisWorkbook.ActiveSheet  
'nLenRow = 1000   '总数据列数  
'nColumn = 1  
bp = False 
    For i = 0 To nLenName - 1  
        'Set rg = ws.Cells(nRow, nColumn)  
        If StrComp(xx, sName(i)) = 0 Then 
            bp = True 
            Exit For 
        End If 
    Next 
    If Not bp Then 
        CanAdd = False 
    End If 
 
'If StrComp(xx, "CCtalk") = 0 Then  
 
  ' CanAdd = False  
 
'End If  
'rg.Activate  
 
End Sub 
 
 
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)  
  'GoUp & NewFolker  
  If Button.Index = 1 Then 
    JamShellTree1.GoUp  
  End If 
  If Button.Index = 2 Then 
    JamShellList1.CreateDir "New Folder", True 
  End If 
  'History  
  If Button.Index = 5 Then 
    JamShellList1.MoveInHistory -1  
  End If 
  If Button.Index = 6 Then 
    JamShellList1.MoveInHistory 1  
  End If 
  'Viewstyle  
  If Button.Index = 9 Then 
    JamShellList1.ViewStyle = vsIcon  
  End If 
  If Button.Index = 10 Then 
    JamShellList1.ViewStyle = vsList  
  End If 
  If Button.Index = 11 Then 
    JamShellList1.ViewStyle = vsReport  
  End If 
  If Button.Index = 12 Then 
    JamShellList1.Thumbnails = Not JamShellList1.Thumbnails  
  End If 
  'Properties & Delete  
  If Button.Index = 15 Then 
    JamShellList1.InvokeCommandOnSelected "delete" 
  End If 
  If Button.Index = 16 Then 
    JamShellList1.InvokeCommandOnSelected "properties" 
  End If 
End Sub 
 
Private Sub UserForm_Activate()  
  Dim b As Button  
  JamShellTree1.ShellLink = JamShellLink1  
  JamShellList1.ShellLink = JamShellLink1  
  JamShellCombo1.ShellLink = JamShellLink1  
  JamThumbnailImage1.ShellLink = JamShellLink1  
  Toolbar1.ImageList = ImageList1  
  'GoUp & NewFolker  
  Toolbar1.Buttons.Add 1, "", "", ButtonStyleConstants.tbrDefault, 1  
  Toolbar1.Buttons.Add 2, "", "", ButtonStyleConstants.tbrDefault, 6  
  Toolbar1.Buttons.Add 3, "", "", ButtonStyleConstants.tbrPlaceholder, 0  
  Toolbar1.Buttons.Add 4, "", "", ButtonStyleConstants.tbrPlaceholder, 0  
  'History  
  Toolbar1.Buttons.Add 5, "", "", ButtonStyleConstants.tbrDefault, 9  
  Toolbar1.Buttons.Add 6, "", "", ButtonStyleConstants.tbrDefault, 3  
  Toolbar1.Buttons.Add 7, "", "", ButtonStyleConstants.tbrPlaceholder, 0  
  Toolbar1.Buttons.Add 8, "", "", ButtonStyleConstants.tbrPlaceholder, 0  
  'Viewstyle  
  Toolbar1.Buttons.Add 9, "", "", ButtonStyleConstants.tbrDefault, 4  
  Toolbar1.Buttons.Add 10, "", "", ButtonStyleConstants.tbrDefault, 5  
  Toolbar1.Buttons.Add 11, "", "", ButtonStyleConstants.tbrDefault, 8  
  Toolbar1.Buttons.Add 12, "", "", ButtonStyleConstants.tbrDefault, 11  
  Toolbar1.Buttons.Add 13, "", "", ButtonStyleConstants.tbrPlaceholder, 0  
  Toolbar1.Buttons.Add 14, "", "", ButtonStyleConstants.tbrPlaceholder, 0  
  'Properties & Delete  
  Toolbar1.Buttons.Add 15, "", "", ButtonStyleConstants.tbrDefault, 2  
  Toolbar1.Buttons.Add 16, "", "", ButtonStyleConstants.tbrDefault, 7  
  Toolbar1.Buttons.Add 17, "", "", ButtonStyleConstants.tbrPlaceholder, 0  
  Toolbar1.Buttons.Add 18, "", "", ButtonStyleConstants.tbrPlaceholder, 0  
End Sub 
'转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/104.html  
Private Sub UserForm_Initialize()  
Dim hWndForm As Long 
  Dim IStyle As Long 
  hWndForm = FindWindow("ThunderDFrame", Me.Caption)  
  IStyle = GetWindowLong(hWndForm, GWL_STYLE)  
  IStyle = IStyle Or WS_THICKFRAME '还原  
  IStyle = IStyle Or WS_MINIMIZEBOX '最小化  
  IStyle = IStyle Or WS_MAXIMIZEBOX '最大化  
  SetWindowLong hWndForm, GWL_STYLE, IStyle  
 
End Sub 

2、利用Excel VBA对筛选后的文件名进行记录

 

 
 
Option Explicit  
Public sName(1000) As String  '2013.1.27 by lijilin  
Public nLenName As Integer    '2013.1.27 by lijilin  
 
Sub Macro1()  
Application.ScreenUpdating = False '程序运行时不刷屏，省时且专业  
Manegement  
UserForm1.JamShellList1.FullRefresh  
Application.ScreenUpdating = True 
End Sub 
 
Sub Macro2()  
Application.ScreenUpdating = False 
UserForm1.Show  
Application.ScreenUpdating = True 
End Sub 
Sub Macro3()  
Application.OnKey "^l", "Macro1" 
Application.OnKey "^k", "Macro2" 
Application.OnKey "^j", "Macro4" 
End Sub 
Sub Macro4()  
Application.ScreenUpdating = False 
UserForm2.Show  
Application.ScreenUpdating = True 
End Sub 
Public Sub Manegement()  '2013.1.27 by lijilin  
'Dim sName(10) As String  
'Dim nLenName As Integer  
'Dim nNumber(10) As Integer  
Dim i As Integer 
Dim rg As Range  
Dim nRow As Integer 
Dim nLenRow As Integer 
Dim nColumn As Integer 
Dim ws As Worksheet  
Application.ScreenUpdating = False '程序运行时不刷屏，省时且专业  
Set ws = ThisWorkbook.ActiveSheet  
nLenRow = 3500   '总数据列数  
nLenName = 0  
nColumn = 1    '统计第1列的数据，名称放到sName()中，数量放到nNumber()中，个数为nLenName  
'For i = 0 To 10  
    'nNumber(i) = 0  
'Next  
For nRow = 2 To nLenRow       '从第二行开始扫描数据，第一行为标题名称  
    Set rg = ws.Cells(nRow, nColumn)  
    If Not IsEmpty(rg) And Not rg.Rows.Hidden Then  '将筛选后的文件名统计2013.1.27 by lijilin  
        For i = 0 To nLenName - 1  
            If StrComp(sName(i), rg.Value) = 0 Then 
                'nNumber(i) = nNumber(i) + 1  
                Exit For 
            End If 
        Next 
        If i = nLenName Then    '很有意思 2013.1.27 by lijilin  
            sName(nLenName) = rg.Value  
            'nNumber(nLenName) = 1  
            nLenName = nLenName + 1  
        End If 
    End If 
Next 
Application.ScreenUpdating = True 
End Sub 
 

3、利用Excel SQL制作特殊的筛选器

 

 
 
Private Sub CommandButton1_Click()  
  ExSQL (TextBox1.Text)  
End Sub 
 
'Option Explicit  
 
Function ExSQL(strTemp)  
 
Application.ScreenUpdating = False '关闭屏幕刷新,成对出现，提高速度  
'Range(Cells(1, 1), Cells(1, 1)).Rows.EntireRow.Hidden = True  
'Range(Cells(1, 1), Cells(1, 1)).Rows.EntireRow.Hidden = False  
'Range(Cells(1, 1), Cells(1, 1)).Rows.EntireRow.Delete  
'Range(Cells(1, 1), Cells(1, 1)).Rows.EntireRow.Insert  
Dim ws As Worksheet  
Dim rg As Range  
Set ws = ThisWorkbook.ActiveSheet  
Dim nEndRow As Integer  '求sheet的行数和列数  
Dim nEndColumn As Integer 
With ws.UsedRange  
    nEndRow = .Rows.Count + .Row - 1  
    nEndColumn = .Columns.Count + .Column - 1  
End With 
Set rg = ws.Range(ws.Cells(1, nEndColumn + 1), ws.Cells(nEndRow, nEndColumn + 1))  
'rg.Columns.EntireColumn.Insert  
rg = "=row()" 
Dim cn As ADODB.Connection '定义数据库连接  
Set cn = New ADODB.Connection '创建数据库连接  
With cn  
.Provider = "Microsoft.Jet.OLEDB.4.0" 
.ConnectionString = "Data Source=" & ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ";" & "Extended Properties=Excel 8.0;"  
.Open  
End With 
Dim rs As ADODB.Recordset '定义一个数据集保存数据  
Set rs = New ADODB.Recordset '创建一个数据集保存数据  
rs.ActiveConnection = cn  
Dim strSQL As String '定义SQL语句  
 
strSQL = "select F" & nEndColumn + 1 & " from [" & ws.Name & "$] where " & strTemp  
rs.Open strSQL, , 3, 2 '执行SQL查询 后面不加，，3，2，则指针向前，rs.recordcount=-1****！！！2013.2.4 by lijilin  
'ThisWorkbook.Sheets(3).[a2].CopyFromRecordset cn.Execute(sql_str)  
'****************SQL得到的结果数据来源于sheet,如果sheet变，SQL得到的结果会跟着变*********  
'****************故要获得正确的结果，数据源sheet不能动！！**********2013.2.4 by lijilin  
'如清空了数据源就得不到正确的结果了！！！！！！！！！**********************************  
'ThisWorkbook.Sheets(2).Cells.ClearContents       '清理保存数据的区域---调试用  
'ThisWorkbook.Sheets(2).[a1].CopyFromRecordset rs  
'ThisWorkbook.Sheets(2).Range("a2").CopyFromRecordset rs '----调试用  
Dim nRow(5000) As Integer 
Dim nLenRow As Integer 
Dim i As Integer 
'nLenRow = rs.PageSize  
If Not (rs.BOF And rs.EOF) Then    '处理无数据无法移动的情况  
 rs.MoveFirst     '******！！！2013.2.4 by lijilin  
'If rs.recordcount > 0 Then   '*****？rs.recordcount=-1  rs.Open strSQL指针向前产生  
    i = 0  
    Do While Not rs.EOF  
        nRow(i) = rs.Fields(0).Value  
        rs.MoveNext  
        i = i + 1  
    Loop 
    nLenRow = i  
'End If  
End If 
'For i = 0 To rs.Fields.Count - 1  '测试字段名  
  '  ws.Cells(13, i + 2) = rs.Fields(i).Name  
'Next  
rs.Close  
cn.Close  
'For i = 0 To nLenRow - 1          '测试查询的值  
 '   ws.Cells(14, i + 2) = nRow(i)  
'Next  
rg.Columns.EntireColumn.Delete  
 
Dim j As Integer 
For i = 2 To nEndRow  
    Set rg = ws.Range(ws.Cells(i, 1), ws.Cells(i, 1))  
    For j = 0 To nLenRow - 1  
        If i = nRow(j) Then 
            Exit For 
        End If 
    Next 
    If j = nLenRow Then 
        rg.Rows.EntireRow.Hidden = True 
    Else 
        rg.Rows.EntireRow.Hidden = False 
    End If 
Next 
Application.ScreenUpdating = True '打开屏幕刷新,成对出现，提高速度  
End Function 
 

4、当workbook打开时将快捷键导入

 

 
 
Private Sub Workbook_Open()  
  'UserForm1.Show  
  'Application.OnKey "^l", "Macro2"  
  Macro3  
End Sub 

5、不同工作薄数据拷贝代码——自动办公代码

 

 
 
Sub M2()  
'  
' Macro1 Macro  
'  
 
'  
Dim wb As Workbook  
Set wb = Application.Workbooks(2)  
Dim rg As Range  
Dim ws As Worksheet  
Set ws = wb.Worksheets(1)  
Set rg = ws.Range("Z445:Z979")  
'rg.Select  
rg.Copy  
 
Tabelle2.Range("AE445:AE979").PasteSpecial  
 
 
End Sub 
 
Sub M3()  
'  
' Macro1 Macro  
'  
 
'  
Dim wb As Workbook  
Set wb = Application.Workbooks(2)  
Dim ws As Worksheet  
Set ws = wb.Worksheets(1)  
'ws.Range("A1").Select  
For i = 1 To 1758  
    ws.Range("AG" & i & ":CD" & i).Copy  
    Tabelle2.Range("AT" & i & ":CQ" & i).PasteSpecial  
Next 
 
 
End Sub