После публикации статьи Сканирование и 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 к скрипту. Как это сделать показано на видео.
По моему этот метод гораздо лучше предыдущего)
Будут вопросы пишите!
не даёт выбрать сканер, сразу переходит на тот сканер, который был ранее.
Где может быть мой косяк? в ONE NOTE при добавлении изображения со сканирования даёт на выбор 4 сканера.
Леонид, попробуйте удалить скрипт и повторить все заново. На 2 ПК делал (Win 7 и Win 8) Все ок было в обоих случаях.
У меня МФУ kyocera 6525. В комплекте TWIN драйверы. Скрипт выдает ошибку: Не доступно ни одно WIA-устройство выбранного типа. Поправить скрип можно?
Леонид, извините, но скрипт нашел у чешского админа, кое-как перевел его статью и запостил тут скрипт. И к сожалению не запомнил его адрес.. если придет в голову какая то мысль я вам напишу.
А как быть с 64 битными системами? У меня выдает ошибку на win7 x64.
Вообще странно, я тестировал и на windows 8 и на семерке, какая ошибка?
Функция SHGetSpecialFolderLocation устарела. Подправил скрипт, работает на Word 2013.
Option Explicit
Sub Scan()
‘Based on a macro by Gunter Born http://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 = Environ(«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
Это я так понял для wia драйвера. Для twain не подходит.
Хорошо было бы скрипт в нормальном виде получить, а не одной строчкой)
Кстати вот для 2010 офиса скрипт
Sub InsertFromScanner()
On Error Resume Next
WordBasic.InsertImagerScan
End Sub
Забирайте)
спасибо
на винде 64 бита выдает ошибку
что то у меня код ошибку пишет
Public Const CSIDL_LOCAL_APPDATA = &H1C ‘\Local Settings\Application Data
Public Const MAX_PATH = 260
Public Const NOERROR = 0
Помогите, что это