Opening jpeg file and saving it from vba in excel

[haplc]

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

 

[GWteB]

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]

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]

Try this:

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]

Many many thanks.

It is working perfectly fine.

With kind regards

 

[GWteB]

You are welcome & thanks for letting me know.