' Scanner-Button für Office 2016 / 2019 / 365 - 32/64 Bit // auch Windows 7 +  Office 2013
' Author: Günter Born www.borncity.de www.borncity.com/blog
' Ergänzt: Andreas Killer - Independent Advisor https://answers.microsoft.com/en-us
' Implementiert für MS Word, MS Exel, MS Powerpoint, MS Publisher, MS Outlook
 
Sub Scan()
   Const olEditorWord = 4
   Dim objCommonDialog As WIA.CommonDialog
   Dim objImage As WIA.ImageFile
   Dim strDateiname As String
   Dim ActiveObject As Object, ActiveTarget As Object
   ' 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
 
     'Insert the picture into the office application:
     Select Case Trim$(Replace$(Application.Name, "Microsoft", ""))
     
       Case "Excel"
         Set ActiveObject = CallByName(Application, "ActiveSheet", VbGet)
         Set ActiveTarget = CallByName(Application, "ActiveCell", VbGet)
         If ActiveTarget Is Nothing Then
           'Insert into a chart, etc.
           ActiveObject.Shapes.AddPicture _
             strDateiname, False, True, 0, 0, -1, -1
         Else
           'Insert into a sheet at the active cell
           ActiveObject.Shapes.AddPicture _
             strDateiname, False, True, ActiveTarget.Left, ActiveTarget.Top, -1, -1
         End If
 
       Case "Outlook"
         Set ActiveObject = CallByName(Application, "ActiveInspector", VbGet)
         If ActiveObject Is Nothing Then
           MsgBox "Create a new mail and try again"
           Exit Sub
         End If
         With ActiveObject
           If .IsWordMail And .EditorType = olEditorWord Then
             .WordEditor.Application.Selection.InlineShapes.AddPicture strDateiname
           End If
         End With
 
       Case "PowerPoint"
         Set ActiveObject = CallByName(ActiveWindow, "View", VbGet)
         ActiveObject.Slide.Shapes.AddPicture strDateiname, False, True, 0, 0, -1, -1
 
       Case "Publisher"
         Set ActiveObject = CallByName(Application, "ActiveDocument", VbGet)
         ActiveObject.ActiveView.ActivePage.Shapes.AddPicture strDateiname, False, True, 0, 0, -1, -1
 
       Case "Word"
         Set ActiveObject = CallByName(Application, "Selection", VbGet)
         ActiveObject.InlineShapes.AddPicture strDateiname
     End Select
   End If
 End Sub