sysrtfm

После публикации статьи Сканирование и MS Office 2010 я получил много положительных отзывов о этой фишке. Но после Выхода в свет MS Office 2013, оказалось, что в новой версии офиса, старые скрипты не работают. Ну ни чего страшного я нашел еще один. После небольшой настройки можно будет запускать мастер сканирования в Word и удобно сканировать документ))). Наглядно, как это работает, можно посмотреть на видео:

Теперь перейдем к подробностям.

Создаем как и раньше кнопку со скриптом, а внутрь помещаем код:

Option Explicit

Public Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hwnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long

Public Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

Public Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data
Public Const MAX_PATH = 260
Public Const NOERROR = 0


Public Function TempFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
TempFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function


Sub Scan()
'Based on a macro by Günter Born www.borncity.de blog.borncity.com
'Requires a reference to Microsoft Windows Image Acquisition Object Library
' 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 = SpecFolder(&H1C) & "\Temp\TempScan.jpg" ' set temporary file location

If Not objImage Is Nothing Then
objImage.SaveFile strPath ' save into temporary file
'Insertion alternatives ++++++++++++++
Selection.InlineShapes.AddPicture strPath ' Insert in Word Document
'ActiveSheet.Pictures.Insert(strPath).Select 'Insert in Excel
'If TypeName(ActiveWindow) = "Inspector" Then 'Insert into Outlook message
' If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
' ActiveInspector.WordEditor.Application.Selection.InlineShapes.AddPicture strPath
' End If
'End If
'+++++++++++++++++++++++++++++++++++++
Set objImage = Nothing
End If
If Not Dir(strPath) = vbNullString Then Kill strPath 'Remove the temporary file
Set objCommonDialog = Nothing
End Sub


Public Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function

Есть один нюанс, в редакторе VB необходимо добавить библиотеку Microsoft Windows Image Acquisition object к скрипту. Как это сделать показано на видео.

По моему этот метод гораздо лучше предыдущего)

Будут вопросы пишите!