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

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

 

Question Info


Last updated November 11, 2019 Views 2,063 Applies to:
Answer
Answer

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

1 person was helped by this reply

·

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.