vba shell 調用和vba 檔案操作

在調用SHELL之前，必須要通過以下步驟：（以在E：盤根目錄下操作為例）
1、強制改變當前的磁碟機：　ChDrive "E"
2、強制改變預設的工作目錄：chdir "E:/"
完成以上動作之後，再來調用E：/的批次檔：shell "e:/234.bat"
這樣執行的效果就和DOS下執行的效果一致。

原因在哪？這是因為SHELL的工作切入點是在Application的預設工作目錄中，也就是說，除非在批處理中強行界定目標路徑，否則，SHELL執行批處理時永遠都是Application的預設工作目錄下進行。
而Application的預設工作目錄一般都是“我的文件”。你可以這樣實驗一下，在E：/建立一個批處理234.bat，內容是　dir >123.inf ，就是將dir列表寫進到123.inf檔案中，然後在立即視窗中shell "E:/234.bat" ，之後再用windows的搜尋功能，搜尋一下剛剛產生的123.inf檔案，你就會發現這個檔案是在“我的文件”中，而不是在E：/下，而在DOS下直接執行234.bat，則結果檔案就自然在E:/下。
如果是在立即視窗中，依次執行
ChDrive "E"
chdir "E:/"
shell "e:/234.bat"
你再看一下，產生的檔案就在E：/下了。

 

Option Explicit

'version 0.1 2009/08/05 add Attached_SaveAs

Sub Attached_SaveAs()

'執行前，在工具，引用中加入"Microsoft   Scripting   Runtime"
    Dim fso As New FileSystemObject
    Dim fldr As Folder
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists("d:/GDS_HUB_Report_Used_by_Rita") Then             '判斷是否存在這個檔案夾
        fso.DeleteFolder ("d:/GDS_HUB_Report_Used_by_Rita")
    Else
        MsgBox "program will create a new Folder which is named 'GDS_HUB_Report_Used_by_Rita' on the D disk!"
    End If
    MkDir "D:/GDS_HUB_Report_Used_by_Rita"
    'Shell "D:/", 0
    'Shell "cd 1", 1

 '調用shell命令前加入改變當前預設路徑
    ChDrive "D"
    ChDir "D:/1/"
    Shell "calc.exe", 1
    Shell "C:/Program Files/7-zip/7z.exe e d:/1/1.rar", 1
    Dim myOlSel As Outlook.Selection
    Dim j, x, cu As Integer
    Dim strFolder As String
    Dim defaultPath As String
    Dim YN As Integer, zipYN As Integer
    Dim i As Long
    Dim oApp As Object
    Set oApp = CreateObject("Shell.Application")
    Set myOlSel = Application.ActiveExplorer.Selection
    defaultPath = "D:/GDS_HUB_Report_Used_by_Rita/"
    If FileExist("C:/VBAtemp.ini") Then
        Open "c:/VBAtemp.ini" For Input As #1
        Line Input #1, defaultPath
        Close #1
        If PathExist(defaultPath) Then
            YN = MsgBox(defaultPath, vbYesNo, "Save file to this path ?")
            If YN = vbNo Then
                strFolder = getFOLDER()
            Else
                strFolder = defaultPath
            End If
        Else
            strFolder = getFOLDER()
        End If
    Else
        strFolder = getFOLDER()
    End If
    zipYN = MsgBox("auto unzip ?", vbYesNo, "auto unzip ?")
   
    For x = 1 To myOlSel.Count
        With myOlSel.Item(x)
            cu = 0
            cu = .Attachments.Count
   
            If cu > 0 Then
                For j = 1 To cu
                    On Error Resume Next
                   
                    If FileExist(strFolder & "/" & .Attachments(j).DisplayName) Then
                        .Attachments(j).SaveAsFile (strFolder & "/" & .Attachments(j).DisplayName & "_double" & i)
                        If FileDateTime(strFolder & "/" & .Attachments(j).DisplayName) > FileDateTime(strFolder & "/" & .Attachments(j).DisplayName & "_double") Then
                            Kill strFolder & "/" & .Attachments(j).DisplayName & "_double"
                        Else
                            Kill strFolder & "/" & .Attachments(j).DisplayName
                            Name strFolder & "/" & .Attachments(j).DisplayName & "_double" As strFolder & "/" & .Attachments(j).DisplayName
                        End If
                    Else
                        .Attachments(j).SaveAsFile (strFolder & "/" & .Attachments(j).DisplayName)
                        i = i + 1
                    End If
'                    If FileExist(strFolder & "/" & .Attachments(j).DisplayName) Then
'                        i = i + 1
'                    End If
                    If zipYN = vbYes Then
                    If UCase(Right(strFolder & "/" & .Attachments(j).DisplayName, 3)) = "ZIP" Or UCase(Right(strFolder & "/" & .Attachments(j).DisplayName, 3)) = "RAR" Then
                        oApp.NameSpace(strFolder & "/").CopyHere oApp.NameSpace(strFolder & "/" & .Attachments(j).DisplayName).Items
                    End If
                    End If
                Next
            End If
   
        End With
    Next
    MsgBox "Success save " & i & " files", vbOKOnly, "complete"
End Sub

Function getFOLDER() As String
    Dim objShell As Object  'Shell
    Dim objFolder As Object 'Shell32.Folder
    Dim objFolderItem As Object

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.NameSpace(0)
    Set objFolderItem = objFolder.Self

    Set objFolder = objShell.BrowseForFolder(0, "Select a folder:", 0, 0)

    If objFolder Is Nothing Then
        getFOLDER = "Cancel"
    Else
        If objFolder.ParentFolder Is Nothing Then
            getFOLDER = "C:/Documents and Settings/" & Environ("username") & "/" & objFolder
        Else
            getFOLDER = objFolder.Items.Item.Path
        End If
    End If

    Set objFolder = Nothing
    Set objShell = Nothing
   
    If getFOLDER <> "Cancel" Then
        Open "c:/VBAtemp.ini" For Output As #1
            Print #1, getFOLDER
        Close #1
    End If
End Function

Function FileExist(rFile As String) As Boolean
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    FileExist = fs.FileExists(rFile)
End Function

Private Function PathExist(pname) As Boolean
    Dim x As String
    On Error Resume Next
    x = GetAttr(pname) And 0
    If Err = 0 Then PathExist = True _
      Else PathExist = False
End Function