Vba word открыть папку

Here is some more cool knowledge to go with this:

I had a situation where I needed to be able to find folders based on a bit of criteria in the record and then open the folder(s) that were found. While doing work on finding a solution I created a small database that asks for a search starting folder gives a place for 4 pieces of criteria and then allows the user to do criteria matching that opens the 4 (or more) possible folders that match the entered criteria.

Here is the whole code on the form:

Option Compare Database
Option Explicit

Private Sub cmdChooseFolder_Click()

    Dim inputFileDialog As FileDialog
    Dim folderChosenPath As Variant

    If MsgBox("Clear List?", vbYesNo, "Clear List") = vbYes Then DoCmd.RunSQL "DELETE * FROM tblFileList"
    Me.sfrmFolderList.Requery

    Set inputFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

    With inputFileDialog
        .Title = "Select Folder to Start with"
        .AllowMultiSelect = False
        If .Show = False Then Exit Sub
        folderChosenPath = .SelectedItems(1)
    End With

    Me.txtStartPath = folderChosenPath

    Call subListFolders(Me.txtStartPath, 1)

End Sub
Private Sub cmdFindFolderPiece_Click()

    Dim strCriteria As String
    Dim varCriteria As Variant
    Dim varIndex As Variant
    Dim intIndex As Integer

    varCriteria = Array(Nz(Me.txtSerial, "Null"), Nz(Me.txtCustomerOrder, "Null"), Nz(Me.txtAXProject, "Null"), Nz(Me.txtWorkOrder, "Null"))
    intIndex = 0

    For Each varIndex In varCriteria
        strCriteria = varCriteria(intIndex)
        If strCriteria <> "Null" Then
            Call fnFindFoldersWithCriteria(TrailingSlash(Me.txtStartPath), strCriteria, 1)
        End If
        intIndex = intIndex + 1
    Next varIndex

    Set varIndex = Nothing
    Set varCriteria = Nothing
    strCriteria = ""

End Sub
Private Function fnFindFoldersWithCriteria(ByVal strStartPath As String, ByVal strCriteria As String, intCounter As Integer)

    Dim fso As New FileSystemObject
    Dim fldrStartFolder As Folder
    Dim subfldrInStart As Folder
    Dim subfldrInSubFolder As Folder
    Dim subfldrInSubSubFolder As String
    Dim strActionLog As String

    Set fldrStartFolder = fso.GetFolder(strStartPath)

'    Debug.Print "Criteria: " & Replace(strCriteria, " ", "", 1, , vbTextCompare) & " and Folder Name is " & Replace(fldrStartFolder.Name, " ", "", 1, , vbTextCompare) & " and Path is: " & fldrStartFolder.Path

    If fnCompareCriteriaWithFolderName(fldrStartFolder.Name, strCriteria) Then
'        Debug.Print "Found and Opening: " & fldrStartFolder.Name & "Because of: " & strCriteria
        Shell "EXPLORER.EXE" & " " & Chr(34) & fldrStartFolder.Path & Chr(34), vbNormalFocus
    Else
        For Each subfldrInStart In fldrStartFolder.SubFolders

            intCounter = intCounter + 1

            Debug.Print "Criteria: " & Replace(strCriteria, " ", "", 1, , vbTextCompare) & " and Folder Name is " & Replace(subfldrInStart.Name, " ", "", 1, , vbTextCompare) & " and Path is: " & fldrStartFolder.Path

            If fnCompareCriteriaWithFolderName(subfldrInStart.Name, strCriteria) Then
'                Debug.Print "Found and Opening: " & subfldrInStart.Name & "Because of: " & strCriteria
                Shell "EXPLORER.EXE" & " " & Chr(34) & subfldrInStart.Path & Chr(34), vbNormalFocus
            Else
                Call fnFindFoldersWithCriteria(subfldrInStart, strCriteria, intCounter)
            End If
            Me.txtProcessed = intCounter
            Me.txtProcessed.Requery
        Next
    End If

    Set fldrStartFolder = Nothing
    Set subfldrInStart = Nothing
    Set subfldrInSubFolder = Nothing
    Set fso = Nothing

End Function
Private Function fnCompareCriteriaWithFolderName(strFolderName As String, strCriteria As String) As Boolean

    fnCompareCriteriaWithFolderName = False

    fnCompareCriteriaWithFolderName = InStr(1, Replace(strFolderName, " ", "", 1, , vbTextCompare), Replace(strCriteria, " ", "", 1, , vbTextCompare), vbTextCompare) > 0

End Function

Private Sub subListFolders(ByVal strFolders As String, intCounter As Integer)
    Dim dbs As Database
    Dim fso As New FileSystemObject
    Dim fldFolders As Folder
    Dim fldr As Folder
    Dim subfldr As Folder
    Dim sfldFolders As String
    Dim strSQL As String

    Set fldFolders = fso.GetFolder(TrailingSlash(strFolders))
    Set dbs = CurrentDb

    strSQL = "INSERT INTO tblFileList (FilePath, FileName, FolderSize) VALUES (" & Chr(34) & fldFolders.Path & Chr(34) & ", " & Chr(34) & fldFolders.Name & Chr(34) & ", '" & fldFolders.Size & "')"
    dbs.Execute strSQL

    For Each fldr In fldFolders.SubFolders
        intCounter = intCounter + 1
        strSQL = "INSERT INTO tblFileList (FilePath, FileName, FolderSize) VALUES (" & Chr(34) & fldr.Path & Chr(34) & ", " & Chr(34) & fldr.Name & Chr(34) & ", '" & fldr.Size & "')"
        dbs.Execute strSQL
        For Each subfldr In fldr.SubFolders
            intCounter = intCounter + 1
            sfldFolders = subfldr.Path
            Call subListFolders(sfldFolders, intCounter)
            Me.sfrmFolderList.Requery
        Next
        Me.txtListed = intCounter
        Me.txtListed.Requery
    Next

    Set fldFolders = Nothing
    Set fldr = Nothing
    Set subfldr = Nothing
    Set dbs = Nothing

End Sub

Private Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = "" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & ""
        End If
    End If
End Function

The form has a subform based on the table, the form has 4 text boxes for the criteria, 2 buttons leading to the click procedures and 1 other text box to store the string for the start folder. There are 2 text boxes that are used to show the number of folders listed and the number processed when searching them for the criteria.

If I had the Rep I would post a picture… :/

I have some other things I wanted to add to this code but haven’t had the chance yet. I want to have a way to store the ones that worked in another table or get the user to mark them as good to store.

I can not claim full credit for all the code, I cobbled some of it together from stuff I found all around, even in other posts on stackoverflow.

I really like the idea of posting questions here and then answering them yourself because as the linked article says, it makes it easy to find the answer for later reference.

When I finish the other parts I want to add I will post the code for that too.

Here is some more cool knowledge to go with this:

I had a situation where I needed to be able to find folders based on a bit of criteria in the record and then open the folder(s) that were found. While doing work on finding a solution I created a small database that asks for a search starting folder gives a place for 4 pieces of criteria and then allows the user to do criteria matching that opens the 4 (or more) possible folders that match the entered criteria.

Here is the whole code on the form:

Option Compare Database
Option Explicit

Private Sub cmdChooseFolder_Click()

    Dim inputFileDialog As FileDialog
    Dim folderChosenPath As Variant

    If MsgBox("Clear List?", vbYesNo, "Clear List") = vbYes Then DoCmd.RunSQL "DELETE * FROM tblFileList"
    Me.sfrmFolderList.Requery

    Set inputFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

    With inputFileDialog
        .Title = "Select Folder to Start with"
        .AllowMultiSelect = False
        If .Show = False Then Exit Sub
        folderChosenPath = .SelectedItems(1)
    End With

    Me.txtStartPath = folderChosenPath

    Call subListFolders(Me.txtStartPath, 1)

End Sub
Private Sub cmdFindFolderPiece_Click()

    Dim strCriteria As String
    Dim varCriteria As Variant
    Dim varIndex As Variant
    Dim intIndex As Integer

    varCriteria = Array(Nz(Me.txtSerial, "Null"), Nz(Me.txtCustomerOrder, "Null"), Nz(Me.txtAXProject, "Null"), Nz(Me.txtWorkOrder, "Null"))
    intIndex = 0

    For Each varIndex In varCriteria
        strCriteria = varCriteria(intIndex)
        If strCriteria <> "Null" Then
            Call fnFindFoldersWithCriteria(TrailingSlash(Me.txtStartPath), strCriteria, 1)
        End If
        intIndex = intIndex + 1
    Next varIndex

    Set varIndex = Nothing
    Set varCriteria = Nothing
    strCriteria = ""

End Sub
Private Function fnFindFoldersWithCriteria(ByVal strStartPath As String, ByVal strCriteria As String, intCounter As Integer)

    Dim fso As New FileSystemObject
    Dim fldrStartFolder As Folder
    Dim subfldrInStart As Folder
    Dim subfldrInSubFolder As Folder
    Dim subfldrInSubSubFolder As String
    Dim strActionLog As String

    Set fldrStartFolder = fso.GetFolder(strStartPath)

'    Debug.Print "Criteria: " & Replace(strCriteria, " ", "", 1, , vbTextCompare) & " and Folder Name is " & Replace(fldrStartFolder.Name, " ", "", 1, , vbTextCompare) & " and Path is: " & fldrStartFolder.Path

    If fnCompareCriteriaWithFolderName(fldrStartFolder.Name, strCriteria) Then
'        Debug.Print "Found and Opening: " & fldrStartFolder.Name & "Because of: " & strCriteria
        Shell "EXPLORER.EXE" & " " & Chr(34) & fldrStartFolder.Path & Chr(34), vbNormalFocus
    Else
        For Each subfldrInStart In fldrStartFolder.SubFolders

            intCounter = intCounter + 1

            Debug.Print "Criteria: " & Replace(strCriteria, " ", "", 1, , vbTextCompare) & " and Folder Name is " & Replace(subfldrInStart.Name, " ", "", 1, , vbTextCompare) & " and Path is: " & fldrStartFolder.Path

            If fnCompareCriteriaWithFolderName(subfldrInStart.Name, strCriteria) Then
'                Debug.Print "Found and Opening: " & subfldrInStart.Name & "Because of: " & strCriteria
                Shell "EXPLORER.EXE" & " " & Chr(34) & subfldrInStart.Path & Chr(34), vbNormalFocus
            Else
                Call fnFindFoldersWithCriteria(subfldrInStart, strCriteria, intCounter)
            End If
            Me.txtProcessed = intCounter
            Me.txtProcessed.Requery
        Next
    End If

    Set fldrStartFolder = Nothing
    Set subfldrInStart = Nothing
    Set subfldrInSubFolder = Nothing
    Set fso = Nothing

End Function
Private Function fnCompareCriteriaWithFolderName(strFolderName As String, strCriteria As String) As Boolean

    fnCompareCriteriaWithFolderName = False

    fnCompareCriteriaWithFolderName = InStr(1, Replace(strFolderName, " ", "", 1, , vbTextCompare), Replace(strCriteria, " ", "", 1, , vbTextCompare), vbTextCompare) > 0

End Function

Private Sub subListFolders(ByVal strFolders As String, intCounter As Integer)
    Dim dbs As Database
    Dim fso As New FileSystemObject
    Dim fldFolders As Folder
    Dim fldr As Folder
    Dim subfldr As Folder
    Dim sfldFolders As String
    Dim strSQL As String

    Set fldFolders = fso.GetFolder(TrailingSlash(strFolders))
    Set dbs = CurrentDb

    strSQL = "INSERT INTO tblFileList (FilePath, FileName, FolderSize) VALUES (" & Chr(34) & fldFolders.Path & Chr(34) & ", " & Chr(34) & fldFolders.Name & Chr(34) & ", '" & fldFolders.Size & "')"
    dbs.Execute strSQL

    For Each fldr In fldFolders.SubFolders
        intCounter = intCounter + 1
        strSQL = "INSERT INTO tblFileList (FilePath, FileName, FolderSize) VALUES (" & Chr(34) & fldr.Path & Chr(34) & ", " & Chr(34) & fldr.Name & Chr(34) & ", '" & fldr.Size & "')"
        dbs.Execute strSQL
        For Each subfldr In fldr.SubFolders
            intCounter = intCounter + 1
            sfldFolders = subfldr.Path
            Call subListFolders(sfldFolders, intCounter)
            Me.sfrmFolderList.Requery
        Next
        Me.txtListed = intCounter
        Me.txtListed.Requery
    Next

    Set fldFolders = Nothing
    Set fldr = Nothing
    Set subfldr = Nothing
    Set dbs = Nothing

End Sub

Private Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = "" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & ""
        End If
    End If
End Function

The form has a subform based on the table, the form has 4 text boxes for the criteria, 2 buttons leading to the click procedures and 1 other text box to store the string for the start folder. There are 2 text boxes that are used to show the number of folders listed and the number processed when searching them for the criteria.

If I had the Rep I would post a picture… :/

I have some other things I wanted to add to this code but haven’t had the chance yet. I want to have a way to store the ones that worked in another table or get the user to mark them as good to store.

I can not claim full credit for all the code, I cobbled some of it together from stuff I found all around, even in other posts on stackoverflow.

I really like the idea of posting questions here and then answering them yourself because as the linked article says, it makes it easy to find the answer for later reference.

When I finish the other parts I want to add I will post the code for that too.

Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.

DIM myWord AS Word.Application
Set myWord = New Word.Application 'объявляем объект с именем ...
CALL SHELL("explorer D:Рабочая папкаПользователь", vbNormalFocus) 'открыть папку с именем ...
Set myWord = Nothing

Dim myWord As Word.Application
Set myWord = New Word.Application 'объявляем объект с именем ...
Call Shell("explorer D:Рабочая папкаПользователь", vbNormalFocus) 'открыть папку с именем ...
Set myWord = Nothing

    Dim winShell As Object
    Dim w As Object
    
    Set winShell = CreateObject("Shell.Application").Windows
    For Each w In winShell
        If w.LocationURL Like "file:///D:/Рабочая*" Then CallByName w.Document, "CurrentViewMode", VbLet, 3: Exit For
   Next
   
'FVM_ICON = 1
'FVM_SMALLICON = 2
'FVM_LIST = 3
'FVM_DETAILS = 4
'FVM_THUMBNAIL = 5
'FVM_TILE = 6
'FVM_THUMBSTRIP = 7
'FVM_CONTENT = 8

Dim myWord As Word.Application
Set myWord = New Word.Application 'объявляем объект с именем ...
Папка = "D:Рабочая папкаПользователь" 'открываем папку с именем ...
Call Shell("explorer " & Папка, vbNormalFocus)  'открыть папку с именем ...
Set myWord = Nothing

И = Replace$("D:Рабочая папкаПользователь", "", "/")
И1 = Replace$(И, " ", "%20")
Папка = "file:///" & Left$(И1, (Len(И1) - 1))

Dim winShell As Object
Dim w As Object
    
    Set winShell = CreateObject("Shell.Application").Windows
    For Each w In winShell
        Обрабатываемое_окно = w.LocationURL
        If w.LocationURL = Папка Then MsgBox "Зашло в условие": CallByName w.Document, "CurrentViewMode", VbLet, 2: Exit For
   Next

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Const SW_SHOWNORMAL = 1 'сделать окно в режиме нормальный
Const SW_SHOWMINIMIZED = 2 'свернуть окно
Const SW_MAXIMIZE = 3 'сделать окно во весь экран
'___________________________________________________________________________
Private Sub CommandButton1_Click()
 
  Dim Папка As String
  Set objShell = CreateObject("Shell.Application")
  Папка = "D:Рабочая папкаНужное" 'не нужно в конце места нахождения папки ставить наклонную
  objShell.ShellExecute Папка & "", , , , 0 'последняя цифра означает: 0 - скрытое окно
  Sleep 50 'нужна задержка, так как окно не успевает создаться
  For Each w In objShell.Windows
      If InStr(TypeName(w.Document), "ShellFolderView") > 0 Then
         If w.Document.Folder.self.Path = Папка Then
            w.Document.CurrentViewMode = 4
'последняя цифра означает:
'Значки 1
'Значки 2
'Список 3
'Таблица 4
'Эскизы страниц 5
'Плитка 6
'Просмотр диафильмов 7
'Значки 8
         ShowWindow w.hwnd, 3
'SW_SHOWNORMAL = 1 'сделать окно в режиме нормальный
'SW_SHOWMINIMIZED = 2 'свернуть окно
'SW_MAXIMIZE = 3 'сделать окно во весь экран
              Exit For
          End If
      End If
  Next
  Set objShell = Nothing
 
End Sub