Attachment reload

Hello,

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

https://jkp-ads.com/articles/apideclarations.asp

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

and see if this link can help you

https://www.codestack.net/solidworks-api/troubleshooting/macros/32-windows-api-functions-incorrect-use/

Miguel,

Sorry the API and Declarations can not be downloaded from these sites ?

If downloaded and install can all macros written in 32 bit can put to work in 64 bit ? Pls help clarify and explain a little more

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,

is it possible to change the code and have full path as hyperlink in column B

Thanks Miguel,

but when try re-run the macro following error pops-up-, stating  sub or Function not defined, pls help debug further

Function GetDirectory(Optional Msg) As String

  Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
    bInfo.pidlRoot = 0&

' Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If

' Type of directory to return
    bInfo.ulFlags = &H1

' Display the dialog
    x = SHBrowseForFolder(bInfo)

' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function

BTW the previous macro work is all working after replace all the codes you are so kindly shared.

However, the  attached Email Macro not working as written in 32 bit Codes and using BSMTP21 stored in Windows System 32 directory, any  chance to modify and covert  to 64 bit and make it work again, thanks your great help

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/en-us/office/save-a-macro-24a026ef-3145-4bf8-a5f2-2fc7889ff74a

only now will I be able to see your other post

Miguel,

Hello,

for email see the following links, if you still have questions, say

https://www.myonlinetraininghub.com/vba-to-create-pdf-from-excel-worksheet-then-email-it-with-outlook

https://www.myonlinetraininghub.com/automating-emailing-pivot-table-reports

Miguel,

Thanks Miguel,basically the "List Files" Macro error already fixed after follows your advice to modify the code.
But, I am stuck with the Email Macro as still prompt the codes must be upgraded [ 64 Bit ], can you help further how to modify and debug the codes to make it work with Ms.Office 2019 version

Thanks Miguel for changing the code to get path in column B but I was hoping more to get hyperlink in column B that I can click on it and get file open

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,

Thanks!

Thanks Miguel so much ! Ask a bit more , can you put these Email macro codes to a workbook, then we can  try.