Office 2016 - Excel Macro to Insert Scanned Image direct from Scanner into Worksheet with VBA

Question

Hi All,

I am trying to customise a friends Excel 2016 (64 Bit) to include a macro assigned button to insert a scanned image/document direct from her scanner into the worksheet in a single click. She is disabled and struggles with her hands so a 'single click' function is both desirable and less stressful than working through the usual menu structures saving the image and then inserting as a picture. I have successfully implemented the companion macros into both Word 2016 (64 Bit) and Outlook 2016 (64 Bit) and these function like a charm.

The issue with the Excel Macro appears to be either in the path or the 'Selection.ActiveSheet.Pictures' process as the scanner initialises, the scan is processed (visible in preview window) but fails to insert into the worksheet the highlight remaining boxed around the A1 cell but no image appears :(

I am not especially conversant with VBA and so I have so far been unable to identify which part of the code contains the error preventing the insertion in this case and so resolve the problem. I have consulted both the forum and the wider internet extensively and whilst I was able to adapt the Word and Outlook codes successfully using posts both here and links externally suggested by forum experts I am at a loss as to what is wrong!

This is the adapted code I am using, perhaps someone with greater expertise than myself could either test or suggest how I can modify the code to resolve the problem. (BTW. The end user's scanner documents default to  "D:<Username>\Username's Filing Cabinet\Username's Scanned Documents" in case this is applicable to the issue. Also I have saved the Book1 as a 'Excel Macro Enabled Template' in both the 'customised' Excel template location "D:<Username>\Username's Filing Cabinet\Username's Documents\Office Documents\Excel\Templates" and copied to "C:\Users<Username>\AppData\Roaming\Microsoft\Excel\XLSTART" as suggested in one internet post if that helps).

' Scan for Excel 2016 - 64 Bit

' Based Upon Author: Günter Born www.borncity.de blog.borncity.com

' Implements a Scan function in Excel 2016

Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Function TempPath() As String

  Const MaxPathLen = 256 ' Max length of the path, just as big as possible

  Dim FolderName As String ' Name of the folder

  Dim ReturnVar As Long ' Return Value

  FolderName = String(MaxPathLen, 0)

  ReturnVar = GetTempPath(MaxPathLen, FolderName)

  If ReturnVar <> 0 Then

    TempPath = Left(FolderName, InStr(FolderName, Chr(0)) - 1)

  Else

    TempPath = vbNullString

  End If

End Function

Sub Scan()

'

' Scan Macro, to be invoked in Excel 2016

'

  On Error Resume Next

     Dim objCommonDialog As WIA.CommonDialog

     Dim objImage As WIA.ImageFile

     Dim strDateiname

     ' instantiate Scan WIA objects

     Set objCommonDialog = New WIA.CommonDialog

     Set objImage = objCommonDialog.ShowAcquireImage

    strDateiname = TempPath & "Scan.jpg" ' set temporary file

'     strDateiname = "C:\Users\Public\Pictures" & "Scan.jpg"

     If Not objImage Is Nothing Then

       Kill strDateiname

       objImage.SaveFile strDateiname ' save into temp file

       Selection.ActiveSheet.Pictures strDateiname ' insert into worksheet

       Set objImage = Nothing

     End If

     Set objCommonDialog = Nothing

  '  MsgBox strDateiname  ' test output

End Sub

Many thanks in advance of your kind responses.

Best regards,

PC Pilot

Answer 1

Comment out all of your code and try the sub below.

Andreas.

Sub Scan()

  Dim objCommonDialog As WIA.CommonDialog

  Dim objImage As WIA.ImageFile

  Dim strDateiname As String

  ' instantiate Scan WIA objects

  Set objCommonDialog = New WIA.CommonDialog

  Set objImage = objCommonDialog.ShowAcquireImage

  strDateiname = Environ$("TEMP") & "\Scan.jpg" ' set temporary file

  If Not objImage Is Nothing Then

    If Dir(strDateiname) <> "" Then Kill strDateiname

    objImage.SaveFile strDateiname 'save into temp file

    DoEvents

    ActiveSheet.Shapes.AddPicture _

      strDateiname, False, True, ActiveCell.Left, ActiveCell.Top, -1, -1

  End If

End Sub

Answer 2

Hi Andreas,

Thanks a million.......you cracked it.......whooa!!

I recompiled my macro replacing my sub script with yours and it now works like a charm.

For the assistance of anybody else looking for a means of Scanning an Image/Document directly into Excel 2016 (64 Bit) and then assigning a Ribbon Button and/or Quick Action Toolbar to enact the function the complete Macro for Excel 2016 (64 Bit) is shown below:

' Scan for Excel 2016 - 64 Bit

' Author: Günter Born www.borncity.de blog.borncity.com

' Implements a Scan function in Excel 2016

Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Function TempPath() As String

  Const MaxPathLen = 256 ' Max length of the path, just as big as possible

  Dim FolderName As String ' Name of the folder

  Dim ReturnVar As Long ' Return Value

  FolderName = String(MaxPathLen, 0)

  ReturnVar = GetTempPath(MaxPathLen, FolderName)

  If ReturnVar <> 0 Then

    TempPath = Left(FolderName, InStr(FolderName, Chr(0)) - 1)

  Else

    TempPath = vbNullString

  End If

End Function

     Sub Scan()

  Dim objCommonDialog As WIA.CommonDialog

  Dim objImage As WIA.ImageFile

  Dim strDateiname As String

  ' instantiate Scan WIA objects

  Set objCommonDialog = New WIA.CommonDialog

  Set objImage = objCommonDialog.ShowAcquireImage

  strDateiname = Environ$("TEMP") & "\Scan.jpg" ' set temporary file

  If Not objImage Is Nothing Then

    If Dir(strDateiname) <> "" Then Kill strDateiname

    objImage.SaveFile strDateiname 'save into temp file

    DoEvents

    ActiveSheet.Shapes.AddPicture _

      strDateiname, False, True, ActiveCell.Left, ActiveCell.Top, -1, -1

  End If

End Sub

==============================================================

........For Word 2016 (64 Bit)

' Scan for Word 2016 - 64 Bit

' Author: Günter Born www.borncity.de blog.borncity.com

' Implements a Scan function in Word 2016

Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Function TempPath() As String

  Const MaxPathLen = 256 ' Max length of the path, just as big as possible

  Dim FolderName As String ' Name of the folder

  Dim ReturnVar As Long ' Return Value

  FolderName = String(MaxPathLen, 0)

  ReturnVar = GetTempPath(MaxPathLen, FolderName)

  If ReturnVar <> 0 Then

    TempPath = Left(FolderName, InStr(FolderName, Chr(0)) - 1)

  Else

    TempPath = vbNullString

  End If

End Function

Sub Scan()

'

' Scan Macro, to be invoked in Word 2016

'

  On Error Resume Next

     Dim objCommonDialog As WIA.CommonDialog

     Dim objImage As WIA.ImageFile

     Dim strDateiname

     ' instantiate Scan WIA objects

     Set objCommonDialog = New WIA.CommonDialog

     Set objImage = objCommonDialog.ShowAcquireImage

    strDateiname = TempPath & "Scan.jpg" ' set temporary file

'     strDateiname = "C:\Users\Public\Pictures" & "Scan.jpg"

     If Not objImage Is Nothing Then

       Kill strDateiname

       objImage.SaveFile strDateiname ' save into temp file

       Selection.InlineShapes.AddPicture strDateiname ' insert into document

       Set objImage = Nothing

     End If

     Set objCommonDialog = Nothing

  '  MsgBox strDateiname  ' test output

End Sub

============================================================

&..........For Outlook 2016 (64 Bit)

' Scan for Outlook 2016 - 64 Bit

' Author: Günter Born www.borncity.de blog.borncity.com

' Implements a Scan function in Outlook 2016

Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Function TempPath() As String

  Const MaxPathLen = 256 ' Max length of the path, just as big as possible

  Dim FolderName As String ' Name of the folder

  Dim ReturnVar As Long ' Return Value

  FolderName = String(MaxPathLen, 0)

  ReturnVar = GetTempPath(MaxPathLen, FolderName)

  If ReturnVar <> 0 Then

    TempPath = Left(FolderName, InStr(FolderName, Chr(0)) - 1)

  Else

    TempPath = vbNullString

  End If

End Function

Sub Scan()

'

' Scan Macro, to be invoked in Outlook 2016

 'Set a reference to Microsoft Windows Image Acquisition Library V 2.0

     On Error Resume Next

     Dim objCommonDialog As WIA.CommonDialog

     Dim objImage As WIA.ImageFile

     Dim strPath As String

     Set objCommonDialog = New WIA.CommonDialog

     Set objImage = objCommonDialog.ShowAcquireImage

     strPath = Environ("TEMP") & "\TempScan.jpg"        ' set temporary file

     If Not objImage Is Nothing Then

         objImage.SaveFile strPath        ' save into temp file

         On Error GoTo ErrHandler

         If TypeName(ActiveWindow) = "Inspector" Then

             If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then

                 ActiveInspector.WordEditor.Application.Selection.InlineShapes.AddPicture strPath        ' insert in MESSAGE

             End If

         End If

         Kill strPath

     End If

lbl_Exit:

     Set objImage = Nothing

     Set objCommonDialog = Nothing

     Exit Sub

ErrHandler:

     Beep

     Resume lbl_Exit

 End Sub

=================================================================

Thanks Andreas......very much appreciated!! :)

Best Regards,

PC Pilot

Answer 3

I'm pleased to hear that it works.

BTW, you don't need the functions GetTempPath and TempPath anymore, they are not longer used within Sub Scan.

Andreas.

Answer 4

Thanks for the extra info........

PP

Answer 5

For anyone looking to do the same with Office 2016 (32 Bit)....................

Macro Scripts - Office 2016 (32 Bit)

Excel 2016 (32 Bit)

' Scan for Excel 2016 - 32 Bit

' Author: Günter Born www.borncity.de blog.borncity.com

' Implements a Scan function in Excel 2016

     Sub Scan()

   Dim objCommonDialog As WIA.CommonDialog

   Dim objImage As WIA.ImageFile

   Dim strDateiname As String

   ' instantiate Scan WIA objects

   Set objCommonDialog = New WIA.CommonDialog

   Set objImage = objCommonDialog.ShowAcquireImage

   strDateiname = Environ$("TEMP") & "\Scan.jpg" ' set temporary file

   If Not objImage Is Nothing Then

     If Dir(strDateiname) <> "" Then Kill strDateiname

     objImage.SaveFile strDateiname 'save into temp file

     DoEvents

     ActiveSheet.Shapes.AddPicture _

       strDateiname, False, True, ActiveCell.Left, ActiveCell.Top, -1, -1

   End If

 End Sub

===================================================================

Word 2016 (32 Bit)

' Scan for Word 2016 - 32 Bit

' Author: Günter Born www.borncity.de blog.borncity.com

' Implements a Scan function in Word 2016

Sub Scan()

'

' Scan Macro, to be invoked in Word 2016

'

  On Error Resume Next

     Dim objCommonDialog As WIA.CommonDialog

     Dim objImage As WIA.ImageFile

     Dim strDateiname

     ' instantiate Scan WIA objects

     Set objCommonDialog = New WIA.CommonDialog

     Set objImage = objCommonDialog.ShowAcquireImage

'    strDateiname = TempPath & "Scan.jpg" ' set temporary file

     strDateiname = "C:\Users\Public\Pictures" & "Scan.jpg"

     If Not objImage Is Nothing Then

       Kill strDateiname

       objImage.SaveFile strDateiname ' save into temp file

       Selection.InlineShapes.AddPicture strDateiname ' insert into document

       Set objImage = Nothing

     End If

     Set objCommonDialog = Nothing

  '  MsgBox strDateiname  ' test output

End Sub

===================================================================

Outlook 2016 (32 Bit)

' Scan for Outlook 2016 - 32 Bit

' Author: Günter Born www.borncity.de blog.borncity.com

' Implements a Scan function in Outlook 2016

Sub Scan()

'

' Scan Macro, to be invoked in Outlook 2016

'

  On Error Resume Next

     Dim objCommonDialog As WIA.CommonDialog

     Dim objImage As WIA.ImageFile

     Dim strDateiname

     ' instantiate Scan WIA objects

     Set objCommonDialog = New WIA.CommonDialog

     Set objImage = objCommonDialog.ShowAcquireImage

'    strDateiname = TempPath & "Scan.jpg" ' set temporary file

     strDateiname = "C:\Users\Public\Pictures" & "Scan.jpg"

     If Not objImage Is Nothing Then

       Kill strDateiname

       objImage.SaveFile strDateiname ' save into temp file

       ActiveSheet.Pictures strDateiname ' insert into Outlook Message

       'Insert into Outlook message

     'If TypeName(ActiveWindow) = "Inspector" Then

 ' If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then

 ' ActiveInspector.WordEditor.Application.Selection.InlineShapes.AddPicture strPath

 ' End If

 'End If

        Set objImage = Nothing

     End If

     Set objCommonDialog = Nothing

  '  MsgBox strDateiname  ' test output

End Sub

====================================================================

====================================================================