Opening All Files With ms paint

**moke123** · 07-31-2022, 07:21 AM

If you need to visualize what getLbx returns take a look at this. Play with the arguments in the bottom example.

**moke123** · 07-31-2022, 09:25 AM

Originally Posted by DMT Dave

Fixed that one, not used fBrowse, used the following

Code:

'Me.txtFolder = fBrowse(msoFileDialogFolderPicker)
'FillList

Me.txtFolder = Forms!frmMainMenu!cboDrive & "\DCIM\101MSDCF\"

Dim Filename As String
Filename = Dir(Me.txtFolder & "*.jpg", vbNormal)
Do While Len(Filename) > 0
Me.lstImages.AddItem Filename

Filename = Dir()
Loop

If you insist on using Dir() then you need to alter what you have.

Code:

Filename = Dir(Me.txtFolder & "*.jpg", vbNormal)

is incorrect. < & "*.jpg"> does nothing. It does not filter your results.

Code:

Filename = Dir(Me.txtFolder , vbNormal)

is correct but it does not include the path of the file.

Code:

Me.lstImages.AddItem Filename

should be

Code:

Me.lstImages.AddItem Filename & ";" & txtFolder & filename

This will return the 2 columns needed for the multi-select listbox.

IMO, fso is the better tool for what you doing as it has all the methods and properties you need.
for instance if you want to filter for only certain file types you could use fso.GetExtensionName(YourFilePath) which returns the file extension without the "."

then the code would look like

Code:

Private Sub FillList()

    Me.lstImages.RowSource = ""


    Dim fol As Folder
    Dim fil As File
    Dim fso As New FileSystemObject


    Set fol = fso.GetFolder(Me.txtFolder)


    For Each fil In fol.Files


        Select Case fso.GetExtensionName(fil.Path)


        Case "Jpg", "png", "jpeg", "bmp"
        
            Me.lstImages.AddItem fil.Name & ";" & fil.Path


        Case Else
            'do nothing
        End Select


    Next


End Sub

**DMT Dave** · 07-31-2022, 09:44 AM

Hi Moke123, thank you for your suggestions, will take a look and compare to what you suggest is correct, your original sample db does the trick nicely, will try and adapt your suggestions though

Thanks Again

**DMT Dave** · 08-01-2022, 04:35 AM

Hi Moke123. us much I got to admit, your method that you suggested would work a treat if i could get my head around it....

I have got this working though, maybe not as efficient as your method, but it works, the only issue i have, i am generating an email for each image whereas i would like to add the array of images to the mail body, can this be adjusted to do that ?

Once again, sorry i am not able to work your method out which im sure would be super efficient compared to mine

Code:

Dim strPathFrom, strFileName As String, strPathTo As String, arrFiles() As String, strFiles As String, strNewFileName As String, strNameFrom As StringDim i As Integer
Dim strA As String, strFilesResize As String, eDisc As String, eDisc2 As String, myMonth As String, FullName() As String, fName As String, KR As String, strEmailImages As String
Dim SigFile As String, BoxStart As String, BoxEnd As String
Dim myApp As New Outlook.Application
Dim OutAccount As Outlook.Account
Dim myItem As Outlook.MailItem


FullName = Split(Me.txtLogin, " ")
fName = FullName(0)


    myMonth = Format(Now(), "mm")
    If myMonth <> "12" Then
SigFile = "DMT dave@ Email Signature.jpg"
    Else
SigFile = "DMT Xmas Signature.jpg"
    End If
    
TimeNow = Format(Now(), "hh")
If TimeNow < 12 Then
TOD = "Good Morning"
End If
If TimeNow >= 12 Then
If TimeNow < 17 Then
TOD = "Good Afternoon"
End If
End If
If TimeNow > 17 Then
TOD = "Good Evening"
End If


KR = "With Kind Regards"


eDisc = "disclaimer removed on here
BoxStart = "<table style='text-align:left;border:3px solid blue;font-family:calibri;border-collapse:collapse;padding:25px'><tr style='background:white;mso-highlight:blue'>"
BoxEnd = "</tr></table>"


strPathFrom = Forms!frmMainMenu!cboDrive & "\DCIM\101MSDCF\"
If Len(Dir(strPathFrom)) > 0 Then
strFileName = Dir(strPathFrom, vbNormal)
strPathTo = "T:\DMT Ltd\Cam Images\"
    Do While Len(strFileName) > 0
    Name strPathFrom & strFileName As strPathTo & strFileName
    strFileName = Dir()
    Loop


MsgBox ("You Can Now Remove The SD Card From Your Computer"), vbInformation + vbOKOnly, "FILES MOVED"
End If


strNameFrom = "T:\DMT Ltd\Cam Images\"
strFiles = Dir(strNameFrom & "*.jpg")
Do While Len(strFiles) > 0
    i = i + 1
    strNewFileName = "DMT Image " & i & ".jpg"
    Name strNameFrom & strFiles As strNameFrom & strNewFileName
    strFiles = Dir()
    If Me.optResize = False Then
    DoCmd.CancelEvent
    Else
    Shell Chr(34) & "C:\Windows\System32\mspaint.exe" & Chr(34) & " " & _
    Chr(34) & strNameFrom & strNewFileName & Chr(34), 1
    End If
    
    strEmailImages = strNameFrom & strNewFileName


    Set myItem = myApp.CreateItem(olMailItem)
    Set OutAccount = myApp.Session.Accounts.Item(1)
    With myItem
    .To = ""
    .subject = "Images"
    .HTMLBody = Replace(TOD, "|", "<br>") & "<br>" & "<br>" & _
    "Please find images we have taken." & "<br>" & "<br>" & _
    BoxStart & "<br><P><IMG border=2 hspace=0 alt='' src='file:" & strEmailImages & "' align=baseline></P>" & "<br>" & BoxEnd & _
    KR & "<br>" & "<br>" & _
    fName & "<br>" & "<br>" & _
    "<P><IMG border=0 hspace=0 alt='' src='file://T:/DMT Ltd/Logo Media/" & SigFile & "' align=baseline></P>" & "<br>" & "<br>" & _
    "<FONT color=#00008B>" & eDisc & "<br>" & "<FONT color =#00008B>" & eDisc2
    .SendUsingAccount = OutAccount
    .Display
    End With
Loop


 Set myItem = Nothing
 Set OutAccount = Nothing
 Set myApp = Nothing
   
 Me.optResize = False

**moke123** · 08-01-2022, 06:40 AM

I'm trying to wrap my head around your code. One suggestion I have is breaking things down to separate procedures.

Code:

    strPathFrom = Forms!frmMainMenu!cboDrive & "\DCIM\101MSDCF\"
    
    If Len(Dir(strPathFrom)) > 0 Then
        strFileName = Dir(strPathFrom, vbNormal)
        strPathTo = "T:\DMT Ltd\Cam Images\"
        Do While Len(strFileName) > 0
            Name strPathFrom & strFileName As strPathTo & strFileName
            strFileName = Dir()
        Loop




        MsgBox ("You Can Now Remove The SD Card From Your Computer"), vbInformation + vbOKOnly, "FILES MOVED"
    End If




    strNameFrom = "T:\DMT Ltd\Cam Images\"
    strFiles = Dir(strNameFrom & "*.jpg")
    Do While Len(strFiles) > 0
        i = i + 1
        strNewFileName = "DMT Image " & i & ".jpg"
        Name strNameFrom & strFiles As strNameFrom & strNewFileName
        strFiles = Dir()
        If Me.optResize = False Then
            DoCmd.CancelEvent
        Else
            Shell Chr(34) & "C:\Windows\System32\mspaint.exe" & Chr(34) & " " & _
                  Chr(34) & strNameFrom & strNewFileName & Chr(34), 1
        End If

If I'm reading this right you are taking all the images from strPathFrom, renaming them and moving them to strPathTo. You are then resizing the all the images.
This can probably be done in one fell swoop. I would break it out into its own procedure and just call it from your procedure.

I'll write up a procedure and post back.

**moke123** · 08-01-2022, 06:55 AM

I made a small modification to emilio's code by adding in a new file path argument

Code:

'***************************************************** ***************************
''Emilio Sancha   https://www.utteraccess.com/topics/2035296
'* Resize
'* re-scale the image passed as parameter
'* You must include a reference to Microsoft Windows Image Acquisition Library vX.X
'* Arguments: strFile => path of the file to resize
'* lngHeight => height in pixels to apply
'* lngWidth => width in pixels to apply
'* usage: Resize "C:\Temp\test.PNG"
'*ESH 08/16/09
'* If you use this code, respect the authorship and credits
'***************************************************** ***************************


Public Sub ReSize(strFile As String, lngHeight As Long, lngWidth As Long, NewFilePath As String)       'added new argument


    On Error GoTo ReSize_Error
    
    Dim objImage As WIA.ImageFile, _
        IP As WIA.ImageProcess, _
        strScaled As String


    Set objImage = CreateObject("WIA.ImageFile")
    Set IP = CreateObject("WIA.ImageProcess")


    objImage.LoadFile (strFile)
    IP.Filters.Add (IP.FilterInfos("Scale").FilterID)
    IP.Filters(1).Properties("MaximumWidth").Value = lngWidth
    IP.Filters(1).Properties("MaximumHeight").Value = lngHeight
    Set objImage = IP.Apply(objImage)


    'strScaled = Replace$(strFile, ".", "_ReSized.")                        ' commented out
    strScaled = NewFilePath                                                        'added new file path
    ' If the file already exists, I delete it.
    If Not Dir$(strScaled) = vbNullString Then Kill strScaled
    objImage.SaveFile (strScaled)




ReSize_Exit:
    If Not objImage Is Nothing Then Set objImage = Nothing
    If Not IP Is Nothing Then Set IP = Nothing


    On Error GoTo 0
    Exit Sub


ReSize_Error:


    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ReSize, line " & Erl & "."
    Resume ReSize_Exit
End Sub

this code will iterate through your source folder, resize and rename each image and save the resized image to your destination folder

Code:

Sub ResizeRenameMove()


    Dim strFilePath As String
    Dim strSourceFolder As String
    Dim strDestinationFolder As String
    Dim fol As Folder
    Dim fil As File
    Dim i As Integer
    Dim NewName As String


    Dim fso As New FileSystemObject


    'change these paths to your folders
    strSourceFolder = CurrentProject.Path & "\images"
    strDestinationFolder = CurrentProject.Path & "\FDest"


    i = 1


    Set fol = fso.GetFolder(strSourceFolder)


    For Each fil In fol.Files


        NewName = fso.BuildPath(strDestinationFolder, "DMTImage" & i & ".jpg")


        ' call the resize procedure
        ReSize fil.Path, 600, 400, NewName                                                         'change the height and width arguments to what you want
        i = i + 1
    Next


    MsgBox ("You Can Now Remove The SD Card From Your Computer"), vbInformation + vbOKOnly, "FILES MOVED"


End Sub

you should be able to replace this section of code

Code:

strPathFrom = Forms!frmMainMenu!cboDrive & "\DCIM\101MSDCF"
If Len(Dir(strPathFrom)) > 0 Then
strFileName = Dir(strPathFrom, vbNormal)
strPathTo = "T:\DMT Ltd\Cam Images"
    Do While Len(strFileName) > 0
    Name strPathFrom & strFileName As strPathTo & strFileName
    strFileName = Dir()
    Loop


MsgBox ("You Can Now Remove The SD Card From Your Computer"), vbInformation + vbOKOnly, "FILES MOVED"
End If


strNameFrom = "T:\DMT Ltd\Cam Images"
strFiles = Dir(strNameFrom & "*.jpg")
Do While Len(strFiles) > 0
    i = i + 1
    strNewFileName = "DMT Image " & i & ".jpg"
    Name strNameFrom & strFiles As strNameFrom & strNewFileName
    strFiles = Dir()
    If Me.optResize = False Then
    DoCmd.CancelEvent
    Else
    Shell Chr(34) & "C:\Windows\System32\mspaint.exe" & Chr(34) & " " & _
    Chr(34) & strNameFrom & strNewFileName & Chr(34), 1
    End If

with this

Code:

If Me.optResize = true Then ResizeRenameMove

**Welshgasman** · 08-01-2022, 07:03 AM

So open the email ONCE outside the loop?

Dave you really need to understand the code you use. Slapping a few lines together here and there is not going to get you very far.
As suggested break it down into small parts and work on getting one working before moving on to the next.

Having rubbish indentation is not going to help you either.

And that is within code tags

Code:

TimeNow = Format(Now(), "hh")
If TimeNow < 12 Then
TOD = "Good Morning"
End If
If TimeNow >= 12 Then
If TimeNow < 17 Then
TOD = "Good Afternoon"
End If
End If
If TimeNow > 17 Then
TOD = "Good Evening"
End If

It is called a language for a reason.

Originally Posted by DMT Dave

Hi Moke123. us much I got to admit, your method that you suggested would work a treat if i could get my head around it....

I have got this working though, maybe not as efficient as your method, but it works, the only issue i have, i am generating an email for each image whereas i would like to add the array of images to the mail body, can this be adjusted to do that ?

Once again, sorry i am not able to work your method out which im sure would be super efficient compared to mine

Code:

Dim strPathFrom, strFileName As String, strPathTo As String, arrFiles() As String, strFiles As String, strNewFileName As String, strNameFrom As StringDim i As Integer
Dim strA As String, strFilesResize As String, eDisc As String, eDisc2 As String, myMonth As String, FullName() As String, fName As String, KR As String, strEmailImages As String
Dim SigFile As String, BoxStart As String, BoxEnd As String
Dim myApp As New Outlook.Application
Dim OutAccount As Outlook.Account
Dim myItem As Outlook.MailItem


FullName = Split(Me.txtLogin, " ")
fName = FullName(0)


    myMonth = Format(Now(), "mm")
    If myMonth <> "12" Then
SigFile = "DMT dave@ Email Signature.jpg"
    Else
SigFile = "DMT Xmas Signature.jpg"
    End If
    
TimeNow = Format(Now(), "hh")
If TimeNow < 12 Then
TOD = "Good Morning"
End If
If TimeNow >= 12 Then
If TimeNow < 17 Then
TOD = "Good Afternoon"
End If
End If
If TimeNow > 17 Then
TOD = "Good Evening"
End If


KR = "With Kind Regards"


eDisc = "disclaimer removed on here
BoxStart = "<table style='text-align:left;border:3px solid blue;font-family:calibri;border-collapse:collapse;padding:25px'><tr style='background:white;mso-highlight:blue'>"
BoxEnd = "</tr></table>"


strPathFrom = Forms!frmMainMenu!cboDrive & "\DCIM\101MSDCF\"
If Len(Dir(strPathFrom)) > 0 Then
strFileName = Dir(strPathFrom, vbNormal)
strPathTo = "T:\DMT Ltd\Cam Images\"
    Do While Len(strFileName) > 0
    Name strPathFrom & strFileName As strPathTo & strFileName
    strFileName = Dir()
    Loop


MsgBox ("You Can Now Remove The SD Card From Your Computer"), vbInformation + vbOKOnly, "FILES MOVED"
End If


strNameFrom = "T:\DMT Ltd\Cam Images\"
strFiles = Dir(strNameFrom & "*.jpg")
Do While Len(strFiles) > 0
    i = i + 1
    strNewFileName = "DMT Image " & i & ".jpg"
    Name strNameFrom & strFiles As strNameFrom & strNewFileName
    strFiles = Dir()
    If Me.optResize = False Then
    DoCmd.CancelEvent
    Else
    Shell Chr(34) & "C:\Windows\System32\mspaint.exe" & Chr(34) & " " & _
    Chr(34) & strNameFrom & strNewFileName & Chr(34), 1
    End If
    
    strEmailImages = strNameFrom & strNewFileName


    Set myItem = myApp.CreateItem(olMailItem)
    Set OutAccount = myApp.Session.Accounts.Item(1)
    With myItem
    .To = ""
    .subject = "Images"
    .HTMLBody = Replace(TOD, "|", "<br>") & "<br>" & "<br>" & _
    "Please find images we have taken." & "<br>" & "<br>" & _
    BoxStart & "<br><P><IMG border=2 hspace=0 alt='' src='file:" & strEmailImages & "' align=baseline></P>" & "<br>" & BoxEnd & _
    KR & "<br>" & "<br>" & _
    fName & "<br>" & "<br>" & _
    "<P><IMG border=0 hspace=0 alt='' src='file://T:/DMT Ltd/Logo Media/" & SigFile & "' align=baseline></P>" & "<br>" & "<br>" & _
    "<FONT color=#00008B>" & eDisc & "<br>" & "<FONT color =#00008B>" & eDisc2
    .SendUsingAccount = OutAccount
    .Display
    End With
Loop


 Set myItem = Nothing
 Set OutAccount = Nothing
 Set myApp = Nothing
   
 Me.optResize = False

**moke123** · 08-01-2022, 07:09 AM

I have got this working though, maybe not as efficient as your method, but it works, the only issue i have, i am generating an email for each image whereas i would like to add the array of images to the mail body, can this be adjusted to do that ?

Which section of your code adds the image? I don't do much with emails in my apps.
I would assume its just a matter of building the html string and adding it in.

**moke123** · 08-01-2022, 07:45 AM

just guessing at it. you'll have to tweak it a little for the right format.

Code:

Function getImageHtml() As String
    Dim strImages As String
    Dim fol As Folder, fil As File
    Dim sourceFolder As String

    Dim fso As New FileSystemObject

    sourceFolder = CurrentProject.Path & "\FDest"    'change to your folder

    Set fol = fso.GetFolder(sourceFolder)

    For Each fil In fol.Files

        strImages = strImages & "<br><P><IMG border=2 hspace=0 alt='' src='file:" & fil.Path & "' align=baseline></P>" & vbNewLine

    Next

    getImageHtml = strImages
    
Debug.Print getImageHtml

End Function

Output

Code:

<br><P><IMG border=2 hspace=0 alt='' src='file:C:\Users\pd\Desktop\trying things\resizeimage\FDest\DMTImage1.jpg' align=baseline></P>
<br><P><IMG border=2 hspace=0 alt='' src='file:C:\Users\pd\Desktop\trying things\resizeimage\FDest\DMTImage2.jpg' align=baseline></P>
<br><P><IMG border=2 hspace=0 alt='' src='file:C:\Users\pd\Desktop\trying things\resizeimage\FDest\DMTImage3.jpg' align=baseline></P>
<br><P><IMG border=2 hspace=0 alt='' src='file:C:\Users\pd\Desktop\trying things\resizeimage\FDest\DMTImage4.jpg' align=baseline></P>

**Welshgasman** · 08-01-2022, 08:02 AM

I do have a sneaking suspicion that you are going to have to add the files as attachments?
The reason being, is if you look at that email, it will look fine. Send that to me, and I do not have of those paths, so will not see anything except perhaps an image icon?

**DMT Dave** · 08-01-2022, 08:36 AM

Thank you guy's going to try and understand your suggestions and play around

Thanks Again

**moke123** · 08-01-2022, 05:47 PM

Originally Posted by Welshgasman

I do have a sneaking suspicion that you are going to have to add the files as attachments?
The reason being, is if you look at that email, it will look fine. Send that to me, and I do not have of those paths, so will not see anything except perhaps an image icon?

At first blush I agreed with you but just ran a test (I didn't even realize I had outlook)
<img src='C:\Users\pd\Desktop\trying things\resizeimage\FDest\DMTImage3.jpg'> does in fact embed the image in the email.

I wrote a quick procedure and emailed it to myself. I then logged on to work computer remotely and checked email and it worked.

**moke123** · 08-02-2022, 05:41 AM

This worked for me. Obviously change the folder path in getImageHtml to your folder path.

Code:

Sub testOL()
 
 Dim outApp As Object
 Dim outMail As Object
 Dim strBody As String
 
 Set outApp = CreateObject("Outlook.application")
 Set outMail = outApp.createitem(0)
 
 strBody = "<BODY style = Font-size:14pt; font-family:Arial>" & _
 "Hi All, <p>Pics Below<p>" & _
 "Regards,<br>PD<p>"
 
 On Error Resume Next
 
 outMail.to = ""
 outMail.cc ""
 outMail.bcc = ""
 outMail.Subject = "My Subject"
 outMail.Display
 outMail.HTMLBody = strBody & getImageHtml & outMail.HTMLBody
  
 On Error GoTo 0
 
 Set outMail = Nothing
 Set outApp = Nothing
 
 End Sub

Code:

Function getImageHtml() As String
    Dim strImages As String


    Dim fso As New FileSystemObject
    Dim fol As Folder, fil As File
    Dim sourceFolder As String
    sourceFolder = CurrentProject.Path & "\FDest"    'change to your folder


    Set fol = fso.GetFolder(sourceFolder)


    For Each fil In fol.Files
 
        strImages = strImages & "<img src='" & fil.Path & "'>"


    Next


    getImageHtml = strImages


End Function

got to get ready for work but will try later and see if I can break it into 2 pictures per line. Probably using modulus on the picture count.

**DMT Dave** · 08-02-2022, 05:49 AM

Hi Moke123, thank you, will do some testing, I am going to keep both methods, since i started this, it would also be useful to keep the email inside the loop so if gives us the option to send to different email address

Then use your suggested version to send all images to one mail, I may have an Opt to select loop or not

Would i guess right without trying but reading your test, Would I only need to remove the for and next statement ? if i were to select individual mails per image ?

I think the 2 options is better for our purposes

either send all images on one via your suggested

or

send separate mails as an option

**DMT Dave** · 08-02-2022, 01:01 PM

Hi Moke123, i tried your suggestion, all good apart from i can't find where the fDest is set, is it on the end of the line where fDest is ?

i have tried changing fDest to another string (dest Path, can't appear to get the images on email, however, apart from dest path, it opens very quickly with no prompts

Opening All Files With ms paint

Thread Tools

Similar Threads

Opening all pdf files in a folder

Opening AutoCAD files

opening multiple files

Where to paste code for subreport?? ...Format, Paint, Print, or Retreat??

Opening .mdb files under Windows 7

Posting Permissions