Macro written in 32 bit System - Not working in 64 bit System[ Win 10 and Office 2019 Prof]|VBA & Macros|Excel Forum|My Online Training Hub

Hello,

in the following two links, you can view and obtain "Api" & "Declarations"

https://jkp-ads.com/articles/a.....ations.asp

https://www.cadsharp.com/docs/.....trSafe.txt

and see if this link can help you

https://www.codestack.net/soli.....rrect-use/

Miguel,

Good afternoon everyone,

the links that I have indicated are informative sites, where you can find (constants; Declaring API Functions;...) to write in VBA for example

I took a look at your project, and just the module with the name: ( List ), is the one that reports error in 64 bits, right?

you want to have a macro to get all the information from the files in a folder, right?

you don't need API for that


example, works in 32-Bit and 64-Bit

first, add this reference to your project: “Microsoft Scripting Runtime”

next, copy all the following lines and paste in a standard module

Option Explicit

Public Sub allFilesInFolder()

If Not WorksheetExists("Files") Then 'Determine if a worksheet name exist (MACRO)
     On Error Resume Next
     Worksheets.Add.Name = "Files"
     On Error GoTo 0
End If

With Application.ThisWorkbook.Worksheets("Files")
     .Visible = xlSheetVisible
     .Activate
     On Error Resume Next
    ' .Cells.ClearFormats
     .Cells.Delete
     On Error GoTo 0
End With
PauseInEvent (0.001) ' (MACRO) to make a pause

Dim RootFolder$

RootFolder = checkDir
If RootFolder = "" Then Exit Sub

With Application.ThisWorkbook.Worksheets("Files")
     With Range("A1")
         .Formula = "Arquivos do Diretório: " & RootFolder
         .Font.Bold = True
         .Font.Size = 12
     End With

     .Range("A3").Formula = "Path:"
     .Range("B3").Formula = "Name:"
     .Range("C3").Formula = "Creation Date:"
     .Range("D3").Formula = "Last Access Date:"
     .Range("E3").Formula = "Last Modified Date:"

     With Range("A3:E3")
         .Font.Bold = True
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
         ' .WrapText = True
     End With
     ' .Columns("A:H").Autofit
End With

ListFilesInFolder RootFolder, True

End Sub

Private Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)

Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long

Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)

With ActiveSheet
     r = Range("A65536").End(xlUp).Row + 1

     For Each FileItem In SourceFolder.Files
         Cells(r, 1).Formula = FileItem.ParentFolder
         Cells(r, 2).Formula = FileItem.Name
         Cells(r, 3).Formula = FileItem.DateCreated
         Cells(r, 3).NumberFormatLocal = "dd/mm/aaaa hh:mm:ss"
         Cells(r, 4).Formula = FileItem.DateLastAccessed
         Cells(r, 5).Formula = FileItem.DateLastModified
         Cells(r, 5).NumberFormatLocal = "dd/mm/aaaa hh:mm:ss"
         r = r + 1
     Next FileItem
     .Columns("A:H").Autofit
End With

If IncludeSubfolders Then
     For Each SubFolder In SourceFolder.SubFolders
         ListFilesInFolder SubFolder.path, True
     Next SubFolder
End If

If Not SourceFolder Is Nothing Then Set SourceFolder = Nothing
If Not FSO Is Nothing Then Set FSO = Nothing

'ActiveWorkbook.Saved = True

End Sub

Private Function checkDir()

Dim objShell, objFolder, xpath, SecuriteSlash

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Please confirm: Select the folder with the files!", &H1&)

On Error Resume Next
xpath = objFolder.ParentFolder.ParseName(objFolder.Title).path & ""

If objFolder.Title = "Bureau" Then
     xpath = "C:WindowsBureau"
End If

If objFolder.Title = "" Then
     xpath = ""
End If

SecuriteSlash = InStr(objFolder.Title, ":")

If SecuriteSlash > 0 Then
     xpath = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If

checkDir = xpath

If Not objShell Is Nothing Then Set objShell = Nothing
If Not objFolder Is Nothing Then Set objFolder = Nothing

End Function

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean ' Determine if a worksheet name exists in this workbook

On Error Resume Next
     WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "")
On Error GoTo 0

End Function

Public Function PauseInEvent(ByVal Delay As Double) ' WAIT A MOMENT WITH LOOP

Dim TheEndOfTime As Double
TheEndOfTime = Timer + Delay

Do While Timer < TheEndOfTime
     DoEvents
Loop

End Function

place the following procedure to call the macro wherever you want:           Call allFilesInFolder

Miguel,

Hello,

I drew attention in my previous post, that the following reference must be activated: “Microsoft Scripting Runtime”

see the previous image, if you don't, you will always have errors in excel

copy the following lines of code between the lines (-------------------------------------- -------------------)

and paste it into a standard module

I made the change to full.path to be in column ("B")

------------------------------------------------------------------------------------

Option Explicit

Public Sub allFilesInFolder()

If Not WorksheetExists("Files") Then 'Determine if a worksheet name exist (MACRO)
      On Error Resume Next
      Worksheets.Add.Name = "Files"
      On Error GoTo 0
End If

With Application.ThisWorkbook.Worksheets("Files")
      .Visible = xlSheetVisible
      .Activate
      On Error Resume Next
      ' .Cells.ClearFormats
      .Cells.Delete
      On Error GoTo 0
End With
PauseInEvent (0.001) ' (MACRO) to make a pause

Dim RootFolder$

RootFolder = checkDir
If RootFolder = "" Then Exit Sub

With Application.ThisWorkbook.Worksheets("Files")
      With Range("A1")
            .Formula = "Arquivos do Diretório: " & RootFolder
            .Font.Bold = True
            .Font.Size = 12
      End With

      .Range("B3").Formula = "Path:"
      .Range("A3").Formula = "Name:"
      .Range("C3").Formula = "Creation Date:"
      .Range("D3").Formula = "Last Access Date:"
      .Range("E3").Formula = "Last Modified Date:"

      With Range("A3:E3")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            ' .WrapText = True
      End With
      ' .Columns("A:H").Autofit
End With

ListFilesInFolder RootFolder, True

End Sub

Private Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)

Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long

Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)

With ActiveSheet
      r = Range("A65536").End(xlUp).Row + 1

      For Each FileItem In SourceFolder.Files
            ' Cells(r, 1).Formula = FileItem.ParentFolder
            Cells(r, 2).Formula = FileItem.Path
            Cells(r, 1).Formula = FileItem.Name
            Cells(r, 3).Formula = FileItem.DateCreated
            Cells(r, 3).NumberFormatLocal = "dd/mm/yyyy hh:mm:ss"
            Cells(r, 4).Formula = FileItem.DateLastAccessed
            Cells(r, 5).Formula = FileItem.DateLastModified
            Cells(r, 5).NumberFormatLocal = "dd/mm/yyyy hh:mm:ss"
            r = r + 1
      Next FileItem
      .Columns("A:H").AutoFit
End With

If IncludeSubfolders Then
      For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
      Next SubFolder
End If

If Not SourceFolder Is Nothing Then Set SourceFolder = Nothing
If Not FSO Is Nothing Then Set FSO = Nothing

'ActiveWorkbook.Saved = True

End Sub

Private Function checkDir()

Dim objShell, objFolder, xpath, SecuriteSlash

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Please confirm: Select the folder with the files!", &H1&)

On Error Resume Next
xpath = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""

If objFolder.Title = "Bureau" Then
      xpath = "C:WindowsBureau"
End If

If objFolder.Title = "" Then
      xpath = ""
End If

SecuriteSlash = InStr(objFolder.Title, ":")

If SecuriteSlash > 0 Then
      xpath = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If

checkDir = xpath

If Not objShell Is Nothing Then Set objShell = Nothing
If Not objFolder Is Nothing Then Set objFolder = Nothing

End Function

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean ' Determine if a worksheet name exists in this workbook

On Error Resume Next
      WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "")
On Error GoTo 0

End Function

Public Function PauseInEvent(ByVal Delay As Double) ' WAIT A MOMENT WITH LOOP

Dim TheEndOfTime As Double
TheEndOfTime = Timer + Delay

Do While Timer < TheEndOfTime
      DoEvents
Loop

End Function

------------------------------------------------------------------------------------

example to call this macro:

Private Sub CommandButton4_Click()

Call allFilesInFolder

End Sub

you must save your Excel files to support macros (.xlsm), other formats will give errors, see the following link

https://support.microsoft.com/.....c7889ff74a

only now will I be able to see your other post

Miguel,

Hello,

to send by outlook, insert the following code in a standard module

Option Explicit

Public Sub SendOutlookEmail()

Dim objfile As FileSystemObject
Dim xNewFolder As Variant
Dim outlApp As Outlook.Application
Dim outlEmail As Outlook.MailItem
Dim outlName As Outlook.Namespace
Dim xEmailOut As String, xEmailCC As String, xEmailBCC As String, xlist As String
Dim xDir As String, convertDate As String, xFile As String, xPath As String, xAttach As String
Dim xDate As Date
Dim xCol As Long
Dim myWorkb As Workbook, xWorkb As Workbook, thisPath As String

thisPath = ActiveWorkbook.Path & "\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Application.StatusBar = "Please wait ... Outlook email creation procedures in progress!"

Set myWorkb = ActiveWorkbook
xDate = VBA.Date
myWorkb.Sheets(Array("Sheet1", "Sheet2", "Sheet6", "Sheet100","Sheet88")).Copy ' select the sheets (names) of this workbook that you want to include in the copy of this workbook that will be sent

Set xWorkb = ActiveWorkbook

''--------------------------------------------------
''--------------------------------------------------
''--- if we want some sheets of the selection to be invisible to those who will receive the workbook, we must activate and indicate in the next lines
'Range("A1").Select
'xWorkb.Sheets("Sheet1").Visible = False
'xWorkb.Sheets("Sheet2").Visible = False
'xWorkb.Sheets("Sheet3").Visible = False
'xWorkb.Sheets("Sheet4").Visible = False
''...
'xWorkb.Sheets("Sheet6").Select
''--------------------------------------------------
''--------------------------------------------------

xDir = thisPath
convertDate = VBA.Format(xDate, "dd mm yyyy") & "\"
xFile = "new workbook name to be sent " & VBA.Format(xDate, "dd-mm-yyyy") & ".xlsm" ' Full name of the workbook to be created and sent (copies of selected sheets of this workbook)
xPath = xDir & convertDate & xFile

Set objfile = New FileSystemObject

If objfile.FolderExists(xDir & convertDate) Then
          If objfile.FileExists(xPath) Then
                    objfile.DeleteFile (xPath)
                    xWorkb.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                    Application.ActiveWorkbook.Close
          Else
                    xWorkb.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                    Application.ActiveWorkbook.Close
          End If
Else
          xNewFolder = xDir & convertDate
          MkDir xNewFolder
          xWorkb.SaveAs Filename:=xPath, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
          Application.ActiveWorkbook.Close
End If

''>>>>>>>>>>>>>>>>>>>> CHOOSE ONLY ONE OPTION (1 or 2) >>>>>>>>>>>>>>>>>>>>''
'
' OPTION 1 - if you choose this option, you must disable option 2
''--------------------------------------------------
''--------------------------------------------------
''--- if there is an email list in excel sheet, activate the following lines of code
''--- in this example the first line = 2 (with email data), the column ("A") is the (send to), the column ("B") is (send CC), the column ("C") is ( send BCC)
'With myWorkb
'           .Activate
'           .Worksheets("list_of_emails").Visible = True

'           .Worksheets("list_of_emails").Unprotect "1234" ' if protected
'           .Worksheets("list_of_emails").Select
'End With
'
'xEmailOut = "" ' reset/clear
'xEmailCC = "" ' reset/clear
'xEmailBCC = "" ' reset/clear
'
'xCol = 1
'
'Do Until xCol = 4 ' we limited the first 3 columns ("A & B & C")
'           Cells(2, xCol).Select
'           Do Until ActiveCell = ""
'                     xlist = ActiveCell.Value
'                     If xCol = 1 Then xEmailOut = xEmailOut & xlist & "; "
'                     If xCol = 2 Then xEmailCC = xEmailCC & xlist & "; "
'                    If xCol = 3 Then xEmailBCC = xEmailBCC & xlist & "; "
'                     ActiveCell.Offset(1, 0).Select
'          Loop
'          xCol = xCol + 1
'Loop
'
'Range("A1").Select
''--------------------------------------------------
''--------------------------------------------------

' OPTION 2 - if you choose this option, you must disable option 1
''--------------------------------------------------
''--------------------------------------------------
''--- enter the destination email in each of the options
xEmailOut = " " ' insert email here
xEmailCC = " " ' insert email here
xEmailBCC = " " ' insert email here
''--------------------------------------------------
''--------------------------------------------------
''<<<<<<<<<<<<<<<<<<<< CHOOSE ONLY ONE OPTION (1 or 2) <<<<<<<<<<<<<<<<<<<<''

Set outlApp = New Outlook.Application
Set outlName = outlApp.GetNamespace("MAPI")
outlName.Logon

Set outlEmail = outlApp.CreateItem(olMailItem)
outlEmail.To = xEmailOut
outlEmail.CC = xEmailCC
outlEmail.BCC = xEmailBCC
outlEmail.Subject = "Description of the subject text of the email" ' email subject text
outlEmail.Body = vbCrLf & "Hello my friend," _
          & vbCrLf & vbCrLf & "I send a file of our work on the subject in title with the following name: " & VBA.Mid(xFile, 1, VBA.Len(xFile) - 5) & "." _
          & vbCrLf & vbCrLf & "See you soon my friend." _
          & vbCrLf & "Regards," _
          & vbCrLf & vbCrLf & " " _
          & vbCrLf & vbCrLf & " " _
          & vbCrLf & "my name!" _
          & vbCrLf & "my email address!" _
          & vbCrLf & "my phone number!" ' email body

outlEmail.Attachments.Add xPath ' attach the newly created copy of the workbook

''--------------------------------------------------
''--------------------------------------------------
''--- if you want to attach other files, activate the following lines and indicate the full path
'xAttach = "C:\...\4.5.JPG"
'outlEmail.Attachments.Add xAttach ' attach picture
'xAttach = "C:\...\my file.xlsm"
'outlEmail.Attachments.Add xAttach ' attach file
''...
''--------------------------------------------------
''--------------------------------------------------

outlEmail.Display

If Not outlEmail Is nothyng Then Set outlEmail = Nothing
If Not outlName Is nothyng Then Set outlName = Nothing
If Not outlApp Is nothyng Then Set outlApp = Nothing
If Not objfile Is nothyng Then Set objfile = Nothing
If Not xWorkb Is nothyng Then Set xWorkb = Nothing
If Not myWorkb Is nothyng Then Set myWorkb = Nothing

Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

example of how to call the macro (with command button)

Option Explicit

Private Sub CommandButton1_Click()

Call SendOutlookEmail

End Sub

------------------------------------------------------------------------------------------------------------

insert the following code in the sheet where you have the full path of each file, recorded in cells

clicking on a cell, if the path is valid will open the file

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim xPath As String

xPath = Target.Value

Debug.Print xPath

If xPath <> "" Then
          If FileExist(xPath) = False Then GoTo resumeExit:
          Application.ThisWorkbook.FollowHyperlink (xPath)
End If

Exit Sub
resumeExit:
          ' MsgBox "File not found!", vbCritical, "Information!"
          Exit Sub
End Sub

Public Function FileExist(FilePath As String) As Boolean

Dim TestStr As String

On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0

If TestStr = "" Then
          FileExist = False
Else
          FileExist = True
End If

End Function

Miguel,