VBA Express : Excel - Rename TIFF file by embedded TIFF tag

Excel

Rename TIFF file by embedded TIFF tag

Ease of Use

Intermediate

Version tested with

2003, 2007, 2010

Submitted by:

Svet B.

Description:

The code takes a TIFF file and renames it as per the Caller ID tag which is available in TIFF files created by fax software.

Discussion:

Recently I was asked to provide a solution to rename fax .tif files as per the embedded caller ID tag (this tag usually holds the sender name and fax#). The fax software produces image files of .tif format with names such as 401cd94d7edc6a3.tif which obviously is not very friendly. I googled the issue and the only thing found was a piece of VB6 code (quite complicated) using APIs. The developer however, mentioned he was no VB developer and stated that all this can easily be done in C or C++. The truth is this is equally easy doable in VBA. The only hard part for the coder is to deal with the TIFF file structure to get the requested tag needed. In this case the tag ID is 9C45 (hex). Of course, this code can easily be amended to work with any tag contained in a .tif file. Additional info: - there are 2 types of TIFF formats. This code works with the most common format. - when the tag cannot be located or is blank, the file gets renamed with a date/time stamp.

Code:

instructions for use

			Sub RenameTiffFile(tiffFileName As String) 
     'Rename/move TIFF files as per the Caller ID tag
     
    Dim newFileName As String 
    Dim iFileNbr As Integer, iPos As Integer 
    Dim myFileId As Long, MyFileLen As Long, FileLen As Long 
    Dim i As Long, n As Long 
    Dim myArr() As Byte 
    Dim IsTagFound As Boolean 
    Dim TagCount As Integer, iCount As Integer, iCharCount As Integer 
    Dim TagValueOffset As Long, OffsetIFD As Long, TagOffset As Long 
    Dim sCallerID As String, sTag As String, fieldType As String, sCount As String 
    Dim destFolder As String 
     
    iPos = InStrRev(tiffFileName, "") 
    destFolder = Right(tiffFileName, Len(tiffFileName) - iPos) 
    destFolder = Replace(tiffFileName, destFolder, "") 
    iFileNbr = FreeFile 
     
    myFileId = FreeFile 
    Open tiffFileName For Binary As #myFileId 
    MyFileLen = LOF(myFileId) 
    ReDim myArr(MyFileLen - 1) 
    Get myFileId, , myArr() 
    Close myFileId 
     
    i = 0 
     'Check for the TIFF file pattern: II*
    If myArr(i) = &H49 And myArr(i + 1) = &H49 And myArr(i + 2) = &H2A Then 
         
         'Get the offset of IFD - bytes 4 to 7
        OffsetIFD = CLng(&H1000000) * myArr(i + 7) + CLng(&H10000) * myArr(i + 6) + CLng(&H100) * myArr(i + 5) + myArr(i + 4) 
        i = OffsetIFD 
         
         'Count of tags - first 2 bytes of IFD
        TagCount = CInt(&H100) * myArr(i + 1) + myArr(i) 
        i = OffsetIFD + 2 
         
         'Loop through the tags - groups of 12 bytes
        IsTagFound = False 
        For iCount = 1 To TagCount 
            sTag = Format(Hex(myArr(i + 1))) & Format(Hex(myArr(i))) 
            DoEvents 
             
             'Caller ID tag
            If sTag = "9C45" Then 
                iCharCount = CLng(&H1000000) * myArr(i + 7) + CLng(&H10000) * myArr(i + 6) + CLng(&H100) * myArr(i + 5) + myArr(i + 4) 
                TagOffset = CLng(&H1000000) * myArr(i + 11) + CLng(&H10000) * myArr(i + 10) + CLng(&H100) * myArr(i + 9) + myArr(i + 8) 
                sCallerID = "" 
                If TagOffset < MyFileLen Then 
                    For n = TagOffset To TagOffset + iCharCount - 1 
                        sCallerID = sCallerID + Chr(CInt(myArr(n))) 
                    Next 
                     'Remove chars not allowed in a file name
                    sCallerID = Replace(sCallerID, vbNullChar, "") 
                    sCallerID = Replace(sCallerID, Chr(20), "") 
                    sCallerID = Replace(sCallerID, ",", "") 
                    sCallerID = Replace(sCallerID, ":", "") 
                    sCallerID = Replace(sCallerID, "/", "") 
                    sCallerID = Replace(sCallerID, "?", "") 
                    sCallerID = Replace(sCallerID, "*", "") 
                    sCallerID = Replace(sCallerID, "", "") 
                    sCallerID = Replace(sCallerID, "|", "") 
                    sCallerID = Replace(sCallerID, ">", "") 
                    sCallerID = Replace(sCallerID, "<", "") 
                    sCallerID = Replace(sCallerID, "[", "") 
                    sCallerID = Replace(sCallerID, "]", "") 
                    sCallerID = Trim(sCallerID) 
                    If Len(sCallerID) < 3 Then 
                        IsTagFound = False 
                        Exit For 
                    End If 
                Else 
                    IsTagFound = False 
                    Exit For 
                End If 
                 'Rename (can also be used to move, if destFolder is different from source folder)
                newFileName = sCallerID & ".tif" 
                newFileName = destFolder & newFileName 
                Name tiffFileName As newFileName 
                IsTagFound = True 
                Exit For 
            End If 
             
            i = i + 12 
        Next 
         
         'Rename when no "9C45" tag was found
        If IsTagFound = False Then 
            Name tiffFileName As destFolder & Format(Now(), "YYYY-MM-DD-HH-MM-SS") & ".tif" 
        End If 
         
    Else 
        MsgBox "This is not a supported TIFF file format. ", vbCritical, "Error" 
    End If 
     
End Sub

How to use:

This code will work with any Office application, so 1st thing to do is open the application.
Run VBE by pressing Alt-F11.
In VBE: Insert - Module.
Copy/paste the code into the new module.
Save.
Now you can call the sub by this line of code: RenameTiffFile SomeFileName.

Test the code:

I attach an Excel sample workbook. Click the button 'Select TIFF File'. Select a file. Click OK. If the file holds a caller ID tag, it will be renamed by the Caller ID. In the ZIP file you will also find a sample .tif file to test.

Sample File:

Sample Excel Tool to Rename TIFF Files.zip 3.6KB

Approved by Jacob Hilderbrand

This entry has been viewed 6 times.