Opening jpeg file and saving it from vba in excel

haplc

Board Regular
Joined
May 27, 2004
Messages
63
Dear All,

I have an excel sheet with two coloumns: A & B. In Coloumn B, there are names of jpeg files located in one folder. Now I would like to open each jpteg file given in Coloumn B and save as content of corresponding cell in Coloumn A.
For example; if cell b1 contains a name of jpeg file " photo B1". In Cell A1, there is a text "Photo A1". I would like to open "photo B1" and save it as "Photo A1". Using the code below, I am able to open each jpeg using name given in Coloumn B. But I could not manage to save each file as name given in Coloumn A.

ActiveWorkbook.Sheets("Jan 2015").Activate
'Checking for last line
For CellNr = ActiveCell.Row + 1 To iFinalRow
' file should be sved as name given in coloumn A
mpic = ThisWorkbook.Sheets("Jan 2015").Range("a" & CellNr).Value
' file name given in coloumn B shoul dbe opened and saved value given in Coloumn B
cflag = ThisWorkbook.Sheets("Jan 2015").Range("b" & CellNr).Value

' this is working and opening photos name given in Coloumn B.
Shell "mspaint.exe C:\p\" & cflag & ""
' here need to acode to save the file
Next CellNr

Thanks and best regards
 

Some videos you may like

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,124
Office Version
  1. 2013
Platform
  1. Windows
So strictly you want to rename an existing file depending on a cell text. Is there a possibility that a file with the same name already exists?
 

haplc

Board Regular
Joined
May 27, 2004
Messages
63
Yes you are right: would like to rename an exisitng file depending on a cell text.
Second part:
No, the name will be unique
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,124
Office Version
  1. 2013
Platform
  1. Windows
Try this:
VBA Code:
Public Sub RenameFile()

    Const cSourceFolder     As String = "C:\User\AnyFolderWithPhotos"     ' << change accordingly

    Dim sSource     As String
    Dim sTarget     As String
    Dim raOldNames  As Range
    Dim c           As Range
    Dim fso         As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set raOldNames = ThisWorkbook.ActiveSheet.Range("B:B")

    For Each c In raOldNames
        If c.Value <> "" Then
            On Error Resume Next
            sSource = cSourceFolder & "\" & c.Value
            If Err.Number <> 0 Then GoTo SUB_ERROR
            sTarget = cSourceFolder & "\" & c.Offset(0, -1).Value
            If Err.Number <> 0 Then GoTo SUB_ERROR

            On Error GoTo SUB_ERROR
            If fso.FileExists(sSource) Then
                If Not fso.FileExists(sTarget) Then
                    fso.CopyFile sSource, sTarget
                    fso.DeleteFile sSource, True
                Else
                    MsgBox "Unable to rename file!", vbExclamation
                End If
            Else
                MsgBox "File does not exist!", vbExclamation
            End If
        Else
            Exit For
        End If
    Next
    GoTo SUB_DONE

SUB_ERROR:
    MsgBox "Error: " & Err.Number & vbCrLf & _
           "Descr.: " & Err.Description & vbCrLf & _
           "Source: " & Err.Source, vbExclamation
    Err.Clear
SUB_DONE:
    Set c = Nothing
    Set raOldNames = Nothing
    Set fso = Nothing
End Sub
 

haplc

Board Regular
Joined
May 27, 2004
Messages
63
Many many thanks.

It is working perfectly fine.

With kind regards
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,124
Office Version
  1. 2013
Platform
  1. Windows
You are welcome & thanks for letting me know.
 

Watch MrExcel Video

Forum statistics

Threads
1,114,663
Messages
5,549,292
Members
410,908
Latest member
Allen P
Top