Access交流网
  • 设为首页|收藏本站|繁体中文|手机版
  •     
  • Access培训-Access开发平台-Access行业开发

  • 首页
  • 资讯
  • 技巧
  • 源码
  • 行业
  • 资源
  • 活动
  • 关于

技巧

ACCESS数据库

启动/设置/选项/背景

修复/压缩

安全/加密/解密

快捷键

版本升级/其它等

数据表

命名方式/设计规范

表设计

查询

Sql语言基础

选择查询

更新查询

删除查询

追加查询

生成表查询

交叉表查询

SQL特定查询

查询参数

查询综合应用

界面/窗体/控件

标签

文本框

命令按钮

组合框/列表框

选项组/复选框/选项按钮

选项卡

子窗体

窗体本身/综合应用

其它

报表打印

报表设计

高级报表

模块/函数/VBA/API/系统

VBA基础

内置函数

调试/跟踪/Debug

模块/类模块

API/COM/系统相关

字符数字日期

网络通信游戏

加密解密安全

文件处理

经典算法

宏/菜单/工具栏/功能区

宏/脚本

菜单/工具栏

功能区/Ribbon

图表/图形/图像/多媒体

图表

图形/图像

音频

视频/动画

DAO/链接表/ADO/ADP

DAO/链接表/ODBC

ADO/RDO

ADP

ActiveX/第三方控件/插件

Treeview树控件

ListView列表控件

Toolbar工具栏控件

微软其它控件

Dbi-Tech

CodeJock

Grid++Report

FastReport

ComponentOne

加载项/插件/Addin

OFFICE集成/导入导出/交互

Excel导入导出/交互

Word导入导出/交互

PPT交互

Outlook控制/邮件

Text文本文件/INI/CSV

PDF/SWF/XML格式

CAD格式

Sharepoint/其它Office

SqlServer/其它数据库

表

视图

存储过程/触发器

函数

用户/权限/安全

调试/维护

SqlServer其它/综合

发布/打包/文档/帮助

开发版/运行时

打包/发布/部署

开发文档/帮助制作

Access完整行业系统

采购管理系统

销售管理系统

仓库管理系统

人力资源管理HRM

CRM管理系统

MRP/ERP管理系统

BRP/流程优化

其它管理系统

心得/经验/绝招
其它/杂项
Excel技巧

Excel应用与操作

Excel开发编程

Word技巧

Word应用与操作

Word开发编程

Outlook技巧

Outlook应用与操作

Outlook开发编程

热门文章

  • Twain和Wia两个驱动..
  • TWAIN驱动介绍-Acc..
  • 解决“我的电脑”中不显示扫..
  • 如何共享扫描仪
  • 可用来连接扫描仪的国外第三..
  • (转)在C#中使用WIA获..

最新文章

  • Access 获取图片的像..
  • Access在同一页面中调..
  • 解决“我的电脑”中不显示扫..
  • WIA的脚本和NET(扫描..
  • 可用来连接扫描仪的国外第三..
  • 如何共享扫描仪

联系方式

Access交流网(免费Access交流)

QQ:18449932 

网  址:www.access-cn.com

当前位置:首页 > 技巧 > 图表/图形/图像/多媒体 > 图形/图像
图形/图像

Access VBA/VB 通用扫描仪开发模块代码

Access VBA/VB 通用扫描仪开发模块代码


Attribute VB_Name = "mdlTwain"

'*******************************************************************************

'

' Description: VB Module for accessing TWAIN compatible scanner (VB 5, 6)

'

' Author:      Lumir Mik (lmik@seznam.cz)

'

' Version:     1.0

'

' License:     Free to any use. If you change some part of this code, please,

'              mention it here.

'              Receive it as my contribution to free programmer sources

'              in which I found much help and inspiration.

'

' There are 3 public functions in this module:

'

'   1. PopupSelectSourceDialog

'           shows TWAIN dialog for selecting default source for acquisition

'

'   2. TransferWithoutUI

'           transfers one image from TWAIN data source without showing

'           the data source user interface (silent transfer). The programmer

'           can set following attributes of the image:

'               - resolution (DPI)

'               - colour depth - monochromatic, grey, fullcolour

'               - image size and position on the scanner glass

'                       - left, top, right, bottom (in inches).

'           The image is saved into the BMP file.

'

'   3. TransferWithUI

'           transfers one image from TWAIN data source using the data

'           source user interface to set image attributes.

'           The image is saved into the BMP file.

'

'*******************************************************************************


Option Explicit


'-----------------------------

' Declaration for TWAIN_32.DLL

'-----------------------------

Private Declare Function DSM_Entry Lib "Twain_32.dll" _

                                   (ByRef pOrigin As Any, _

                                    ByRef pDest As Any, _

                                    ByVal DG As Long, _

                                    ByVal DAT As Integer, _

                                    ByVal MSG As Integer, _

                                    ByRef pData As Any) As Integer


Private Type TW_VERSION

    MajorNum        As Integer                  ' TW_UINT16

    MinorNum        As Integer                  ' TW_UINT16

    Language        As Integer                  ' TW_UINT16

    Country         As Integer                  ' TW_UINT16

    Info(1 To 34)   As Byte                     ' TW_STR32

End Type


Private Type TW_IDENTITY

    Id                      As Long             ' TW_UINT32

    Version                 As TW_VERSION       ' TW_VERSION

    ProtocolMajor           As Integer          ' TW_UINT16

    ProtocolMinor           As Integer          ' TW_UINT16

    SupportedGroups1        As Integer          ' TW_UINT32

    SupportedGroups2        As Integer

    Manufacturer(1 To 34)   As Byte             ' TW_STR32

    ProductFamily(1 To 34)  As Byte             ' TW_STR32

    ProductName(1 To 34)    As Byte             ' TW_STR32

End Type


Private Type TW_USERINTERFACE

    ShowUI   As Integer                         ' TW_BOOL

    ModalUI  As Integer                         ' TW_BOOL

    hParent  As Long                            ' TW_HANDLE

End Type


Private Type TW_PENDINGXFERS

    Count       As Integer                      ' TW_UINT16

    Reserved1   As Integer                      ' TW_UINT32

    Reserved2   As Integer

End Type


Private Type TW_ONEVALUE

    ItemType As Integer                         ' TW_UINT16

    Item1    As Integer                         ' TW_UINT32

    Item2    As Integer

End Type


Private Type TW_CAPABILITY

    Cap          As Integer                     ' TW_UINT16

    ConType      As Integer                     ' TW_UINT16

    hContainer   As Long                        ' TW_HANDLE

End Type


Private Type TW_FIX32

    Whole   As Integer                          ' TW_INT16

    Frac    As Integer                          ' TW_UINT16

End Type


Private Type TW_FRAME

    Left     As TW_FIX32                        ' TW_FIX32

    Top      As TW_FIX32                        ' TW_FIX32

    Right    As TW_FIX32                        ' TW_FIX32

    Bottom   As TW_FIX32                        ' TW_FIX32

End Type


Private Type TW_IMAGELAYOUT

    Frame            As TW_FRAME                ' TW_FRAME

    DocumentNumber   As Long                    ' TW_UINT32

    PageNumber       As Long                    ' TW_UINT32

    FrameNumber      As Long                    ' TW_UINT32

End Type


Private Type TW_EVENT

    pEvent      As Long                         ' TW_MEMREF

    TWMessage   As Integer                      ' TW_UINT16

End Type


Private Const DG_CONTROL = 1

Private Const DG_IMAGE = 2


Private Const MSG_GET = 1

Private Const MSG_SET = 6

Private Const MSG_XFERREADY = 257

Private Const MSG_CLOSEDSREQ = 258

Private Const MSG_OPENDSM = 769

Private Const MSG_CLOSEDSM = 770

Private Const MSG_OPENDS = 1025

Private Const MSG_CLOSEDS = 1026

Private Const MSG_USERSELECT = 1027

Private Const MSG_DISABLEDS = 1281

Private Const MSG_ENABLEDS = 1282

Private Const MSG_PROCESSEVENT = 1537

Private Const MSG_ENDXFER = 1793


Private Const DAT_CAPABILITY = 1

Private Const DAT_EVENT = 2

Private Const DAT_IDENTITY = 3

Private Const DAT_PARENT = 4

Private Const DAT_PENDINGXFERS = 5

Private Const DAT_USERINTERFACE = 9

Private Const DAT_IMAGELAYOUT = 258

Private Const DAT_IMAGENATIVEXFER = 260


Private Const TWRC_SUCCESS = 0

Private Const TWRC_CHECKSTATUS = 2

Private Const TWRC_DSEVENT = 4

Private Const TWRC_NOTDSEVENT = 5

Private Const TWRC_XFERDONE = 6


Private Const TWLG_CZECH = 45


Private Const TWCY_CZECHOSLOVAKIA = 42


Private Const TWON_PROTOCOLMAJOR = 1

Private Const TWON_ONEVALUE = 5

Private Const TWON_PROTOCOLMINOR = 9



'-------------------------

' Declaration for WIN32API

'-------------------------

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _

                               (ByVal pDest As Long, _

                                ByVal pSource As Long, _

                                ByVal Length As Long)

Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" _

                               (ByVal pDest As Long, _

                                ByVal Length As Long)

Private Declare Function GlobalFree Lib "kernel32.dll" _

                                    (ByVal hMem As Long) As Long

Private Declare Function GlobalLock Lib "kernel32.dll" _

                                    (ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib "kernel32.dll" _

                                      (ByVal hMem As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32.dll" _

                                     (ByVal wFlags As Long, _

                                      ByVal dwBytes As Long) As Long

Private Declare Function GetMessage Lib "user32.dll" Alias "GetMessageA" _

                                    (ByRef lpMsg As MSG, _

                                     ByVal hwnd As Long, _

                                     ByVal wMsgFilterMin As Long, _

                                     ByVal wMsgFilterMax As Long) As Long

Private Declare Function TranslateMessage Lib "user32.dll" _

                                          (ByRef lpMsg As MSG) As Long

Private Declare Function DispatchMessage Lib "user32.dll" Alias "DispatchMessageA" _

                                         (ByRef lpMsg As MSG) As Long

Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" _

                                        (ByVal dwExStyle As Long, _

                                         ByVal lpClassName As String, _

                                         ByVal lpWindowName As String, _

                                         ByVal dwStyle As Long, _

                                         ByVal x As Long, _

                                         ByVal y As Long, _

                                         ByVal nWidth As Long, _

                                         ByVal nHeight As Long, _

                                         ByVal hWndParent As Long, _

                                         ByVal hMenu As Long, _

                                         ByVal hInstance As Long, _

                                         ByVal lpParam As Long) As Long

Private Declare Function DestroyWindow Lib "user32.dll" _

                                       (ByVal hwnd As Long) As Long


Private Type BITMAPFILEHEADER

    bfType      As Integer

    bfSize      As Long

    bfReserved1 As Integer

    bfReserved2 As Integer

    bfOffBits   As Long

End Type


Private Type BITMAPINFOHEADER

    biSize          As Long

    biWidth         As Long

    biHeight        As Long

    biPlanes        As Integer

    biBitCount      As Integer

    biCompression   As Long

    biSizeImage     As Long

    biXPelsPerMeter As Long

    biYPelsPerMeter As Long

    biClrUsed       As Long

    biClrImportant  As Long

End Type


Private Type RGBQUAD

    rgbBlue     As Byte

    rgbGreen    As Byte

    rgbRed      As Byte

    rgbReserved As Byte

End Type


Private Type POINTAPI

    x As Long

    y As Long

End Type


Private Type MSG

    hwnd    As Long

    message As Long

    wParam  As Long

    lParam  As Long

    time    As Long

    pt      As POINTAPI

End Type


Private Const GHND = 66



'----------------------------

' Declaration for this Module

'----------------------------

Private m_tAppID As TW_IDENTITY

Private m_tSrcID As TW_IDENTITY

Private m_lHndMsgWin As Long


Public Enum TWAIN_MDL_COLOURTYPE

    BW = 0                              ' TWPT_BW

    GREY = 1                            ' TWPT_GRAY

    RGB = 2                             ' TWPT_RGB

End Enum


Private Enum TWAIN_MDL_CAPABILITY

    XFERCOUNT = 1                       ' CAP_XFERCOUNT

    PIXELTYPE = 257                     ' ICAP_PIXELTYPE

    INDICATORS = 4107                   ' CAP_INDICATORS

    UICONTROLLABLE = 4110               ' CAP_UICONTROLLABLE

    PHYSICALWIDTH = 4369                ' ICAP_PSYSICALWIDTH

    PHYSICALHEIGHT = 4370               ' ICAP_PSYSICALHEIGHT

    XRESOLUTION = 4376                  ' ICAP_XRESOLUTION

    YRESOLUTION = 4377                  ' ICAP_YRESOLUTION

    BITDEPTH = 4395                     ' ICAP_BITDEPTH

End Enum


Private Enum TWAIN_MDL_ITEMYPE

    INT16 = 1                           ' TW_INT16      short

    UINT16 = 4                          ' TW_UINT16     unsigned short

    BOOL = 6                            ' TW_BOOL       unsigned short

    FIX32 = 7                           ' TW_FIX32      structure

End Enum


Public Function TransferWithoutUI(ByVal sngResolution As Single, _

                                  ByVal tColourType As TWAIN_MDL_COLOURTYPE, _

                                  ByVal sngImageLeft As Single, _

                                  ByVal sngImageTop As Single, _

                                  ByVal sngImageRight As Single, _

                                  ByVal sngImageBottom As Single, _

                                  ByVal sBMPFileName As String) As Long


    '----------------------------------------------------------------------------

    ' Function transfers one image from Twain data source without showing

    '   the data source user interface (silent transfer).

    '

    ' Input values

    '   - sngResolution (Single) - resolution of the image in DPI

    '                              (dots per inch)

    '   - tColourType (UDT) - colour depth of the imaged - monochromatic (BW),

    '                         colours of grey (GREY), full colours (COLOUR)

    '   - sngImageLeft, sngImageTop, sngImageRight, sngImageBottom (Single) -

    '       values determine the rectangle on the scanner glass that will

    '       be scanned (default units are inches) - if you set Right and Bottom

    '       values to 0, the module sets maximum values the scanner driver allows

    '       (the bottom right corner of the scanner glass)

    '   - sBMPFileName (String) - the file name of the saved image

    '

    ' Function returns 0 if OK, 1 if an error occurs

    '----------------------------------------------------------------------------

                                   

    Dim lRtn As Long

    Dim lTmp As Long

    Dim blTwainOpen As Boolean

    Dim lhDIB As Long

    

    On Local Error GoTo ErrPlace


    '-------------------------------

    ' Open Twain Data Source Manager

    '-------------------------------

    lRtn = OpenTwainDSM()

    If lRtn Then GoTo ErrPlace

    blTwainOpen = True


    '-----------------------

    ' Open Twain Data Source

    '-----------------------

    lRtn = OpenTwainDS()

    If lRtn Then GoTo ErrPlace


    '-----------------------------------------------------------

    ' Set all important attributes of the image and the transfer

    '-----------------------------------------------------------

    

    '----------------------------------------------------------------------

    ' Set image size and position

    ' If sngImageRight or sngImageBottom is 0 put physical width and height

    '   of the scanner into these values

    '----------------------------------------------------------------------

    If (sngImageRight = 0) Or (sngImageBottom = 0) Then

        lRtn = TwainGetOneValue(PHYSICALWIDTH, sngImageRight)

        If lRtn Then GoTo ErrPlace

        lRtn = TwainGetOneValue(PHYSICALHEIGHT, sngImageBottom)

        If lRtn Then GoTo ErrPlace

    End If


    lRtn = SetImageSize(sngImageLeft, sngImageTop, sngImageRight, sngImageBottom)

    If lRtn Then GoTo ErrPlace


    '-----------------------------------------------

    ' Set the image resolution in DPI - both X and Y

    '-----------------------------------------------

    lRtn = TwainSetOneValue(XRESOLUTION, FIX32, sngResolution)

    If lRtn Then GoTo ErrPlace


    lRtn = TwainSetOneValue(YRESOLUTION, FIX32, sngResolution)

    If lRtn Then GoTo ErrPlace


    '--------------------------

    ' Set the image colour type

    '--------------------------

    lRtn = TwainSetOneValue(PIXELTYPE, UINT16, tColourType)

    If lRtn Then GoTo ErrPlace

    

    '----------------------------------------------------------------

    ' If the colour type is fullcolour, set the bitdepth of the image

    '   - 24 bits, 32 bits, ...

    '----------------------------------------------------------------

    If tColourType = RGB Then lRtn = TwainSetOneValue(BITDEPTH, UINT16, 24)


    '---------------------------------------------------

    ' Set number of images you want to transfer (just 1)

    '---------------------------------------------------

    lRtn = TwainSetOneValue(XFERCOUNT, INT16, 1)

    If lRtn Then GoTo ErrPlace


    '----------------------------------------------------

    ' TRANSFER the image with UI disabled.

    '   If successful, lhDIB is filled with handle to DIB

    '----------------------------------------------------

    lRtn = TwainTransfer(False, lhDIB)

    If lRtn Then GoTo ErrPlace


    '------------------

    ' Close Data Source

    '------------------

    lRtn = CloseTwainDS()

    If lRtn Then GoTo ErrPlace

    

    '--------------------------

    ' Close Data Source Manager

    '--------------------------

    lRtn = CloseTwainDSM()

    If lRtn Then GoTo ErrPlace

    blTwainOpen = False

    

    '----------------------------------

    ' Save DIB handle into the BMP file

    '----------------------------------

    lRtn = SaveDIBToFile(lhDIB, sBMPFileName)

    If lRtn Then GoTo ErrPlace


    TransferWithoutUI = 0

    Exit Function


ErrPlace:

    If lhDIB Then lRtn = GlobalFree(lhDIB)

    If blTwainOpen Then lRtn = CloseTwainDS(): lRtn = CloseTwainDSM()

    TransferWithoutUI = 1

End Function


Public Function TransferWithUI(ByVal sBMPFileName As String) As Long

        

    '-------------------------------------------------------------------

    ' Function transfers one image from Twain data source using the data

    '   source user interface to set image attributes.

    '

    ' Input values

    '   - sBMPFileName (String) - the file name of the saved image

    '

    ' Function returns 0 if OK, 1 if an error occurs

    '-------------------------------------------------------------

    

    Dim lRtn As Long

    Dim blTwainOpen As Boolean

    Dim lhDIB As Long

    

    On Local Error GoTo ErrPlace


    '-------------------------------

    ' Open Twain Data Source Manager

    '-------------------------------

    lRtn = OpenTwainDSM()

    If lRtn Then GoTo ErrPlace

    blTwainOpen = True


    '-----------------------

    ' Open Twain Data Source

    '-----------------------

    lRtn = OpenTwainDS()

    If lRtn Then GoTo ErrPlace


    '----------------------------------------------------

    ' TRANSFER the image with UI enabled.

    '   If successful, lhDIB is filled with handle to DIB

    '----------------------------------------------------

    lRtn = TwainTransfer(True, lhDIB)

    If lRtn Then GoTo ErrPlace


    '------------------

    ' Close Data Source

    '------------------

    lRtn = CloseTwainDS()

    If lRtn Then GoTo ErrPlace

    

    '--------------------------

    ' Close Data Source Manager

    '--------------------------

    lRtn = CloseTwainDSM()

    If lRtn Then GoTo ErrPlace

    blTwainOpen = False

    

    '----------------------------------

    ' Save DIB handle into the BMP file

    '----------------------------------

    lRtn = SaveDIBToFile(lhDIB, sBMPFileName)

    If lRtn Then GoTo ErrPlace


    TransferWithUI = 0

    Exit Function


ErrPlace:

    If lhDIB Then lRtn = GlobalFree(lhDIB)

    If blTwainOpen Then lRtn = CloseTwainDS(): lRtn = CloseTwainDSM()

    TransferWithUI = 1

End Function


Public Function PopupSelectSourceDialog() As Long

    

    '------------------------------------------------------------------

    ' Function shows the Twain dialog for selecting default data source

    '

    ' Function returns 0 if OK, 1 if an error occurs

    '------------------------------------------------------------------

    

    Dim iRtn As Integer

    Dim lRtn As Long

    

    On Local Error GoTo ErrPlace

    

    '-------------------------------

    ' Open Twain Data Source Manager

    '-------------------------------

    lRtn = OpenTwainDSM()

    If lRtn Then GoTo ErrPlace


    '----------------------------------------------------

    ' Popup "Select source" dialog

    '   DG_CONTROL, DAT_IDENTITY, MSG_USERSELECT

    '----------------------------------------------------

    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, _

                     MSG_USERSELECT, m_tSrcID)

    If iRtn <> TWRC_SUCCESS Then

        lRtn = CloseTwainDSM()

        GoTo ErrPlace

    End If

    

    '--------------------------------

    ' Close Twain Data Source Manager

    '--------------------------------

    lRtn = CloseTwainDSM()

    If lRtn Then GoTo ErrPlace

    

    PopupSelectSourceDialog = 0

    Exit Function

    

ErrPlace:

    PopupSelectSourceDialog = 1

End Function


Private Function OpenTwainDSM() As Long

    

    Dim iRtn As Integer

    

    On Local Error GoTo ErrPlace

    

    '----------------------------------------------------

    ' Create window that will receive all TWAIN messages

    ' Message loop can be found in TwainTransfer function

    '----------------------------------------------------

    m_lHndMsgWin = CreateWindowEx(0&, "#32770", "TWAIN_MSG_WINDOW", 0&, _

                                  10&, 10&, 150&, 50&, 0&, 0&, 0&, 0&)

    If m_lHndMsgWin = 0 Then GoTo ErrPlace

    

    '------------------------------------------------------------

    ' Introduce yourself to TWAIN - MajorNum, MinorNum, Language,

    ' Country, Manufacturer, ProductFamily, ProductName, etc.

    '------------------------------------------------------------

    Call ZeroMemory(VarPtr(m_tAppID), Len(m_tAppID))

    With m_tAppID

        .Version.MajorNum = 1

        .Version.Language = TWLG_CZECH

        .Version.Country = TWCY_CZECHOSLOVAKIA

        .ProtocolMajor = TWON_PROTOCOLMAJOR

        .ProtocolMinor = TWON_PROTOCOLMINOR

        .SupportedGroups1 = DG_CONTROL Or DG_IMAGE

    End With

    

    Call CopyMemory(VarPtr(m_tAppID.Manufacturer(1)), _

                    StrPtr(StrConv("LMik", vbFromUnicode)), _

                    Len("LMik"))

    Call CopyMemory(VarPtr(m_tAppID.ProductFamily(1)), _

                    StrPtr(StrConv("VB Module", vbFromUnicode)), _

                    Len("VB Module"))

    Call CopyMemory(VarPtr(m_tAppID.ProductName(1)), _

                    StrPtr(StrConv("VB Module for TWAIN", vbFromUnicode)), _

                    Len("VB Module for TWAIN"))

    

    '--------------------------------------

    ' Open Data Source Manager

    '   DG_CONTROL, DAT_PARENT, MSG_OPENDSM

    '--------------------------------------

    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_OPENDSM, _

                     m_lHndMsgWin)

    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace

    

    OpenTwainDSM = 0

    Exit Function

    

ErrPlace:

    OpenTwainDSM = 1

End Function


Private Function OpenTwainDS() As Long


    Dim iRtn As Integer

    

    On Local Error GoTo ErrPlace

    

    '----------------------------------------------------------------------

    ' Open Data Source

    '   DG_CONTROL, DAT_IDENTITY, MSG_OPENDS

    '

    ' The default data source is opened. If you want user to select the new

    '   default one, call public function PopupSelectSourceDialog.

    '----------------------------------------------------------------------

    Call ZeroMemory(VarPtr(m_tSrcID), Len(m_tSrcID))

    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, MSG_OPENDS, _

                     m_tSrcID)

    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace


    OpenTwainDS = 0

    Exit Function

    

ErrPlace:

    OpenTwainDS = 1

End Function


Private Function CloseTwainDS() As Long

    

    Dim iRtn As Integer

    

    On Local Error GoTo ErrPlace

    

    '----------------------------------------

    ' Close Data Source

    '   DG_CONTROL, DAT_IDENTITY, MSG_CLOSEDS

    '----------------------------------------

    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, _

                     MSG_CLOSEDS, m_tSrcID)

    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace

    

    CloseTwainDS = 0

    Exit Function


ErrPlace:

    CloseTwainDS = 1

End Function


Private Function CloseTwainDSM() As Long

    

    Dim lRtn As Long

    Dim iRtn As Integer

    

    On Local Error GoTo ErrPlace


    '---------------------------------------

    ' Close Data Source Manager

    '   DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM

    '---------------------------------------

    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM, _

                     m_lHndMsgWin)

    If iRtn <> TWRC_SUCCESS Then

        lRtn = DestroyWindow(m_lHndMsgWin)

        GoTo ErrPlace

    End If


    '---------------------------

    ' Destroy the message window

    '---------------------------

    lRtn = DestroyWindow(m_lHndMsgWin)

    If lRtn = 0 Then GoTo ErrPlace

    

    CloseTwainDSM = 0

    Exit Function


ErrPlace:

    CloseTwainDSM = 1

End Function


Private Function SetImageSize(ByRef sngLeft As Single, _

                              ByRef sngTop As Single, _

                              ByRef sngRight As Single, _

                              ByRef sngBottom As Single) As Long


    Dim tImageLayout As TW_IMAGELAYOUT

    Dim lRtn As Long

    Dim iRtn As Integer

    

    On Local Error GoTo ErrPlace

    

    '-------------------------------------------------------------------

    ' Set the size of the image - in default units

    '   DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET

    '

    ' If you do not select any units the INCHES are selected as default.

    ' The values of Single type are converted into TWAIN TW_FIX32.

    '-------------------------------------------------------------------

    lRtn = FloatToFix32(sngLeft, tImageLayout.Frame.Left)

    If lRtn Then GoTo ErrPlace

    

    lRtn = FloatToFix32(sngTop, tImageLayout.Frame.Top)

    If lRtn Then GoTo ErrPlace

    

    lRtn = FloatToFix32(sngRight, tImageLayout.Frame.Right)

    If lRtn Then GoTo ErrPlace

    

    lRtn = FloatToFix32(sngBottom, tImageLayout.Frame.Bottom)

    If lRtn Then GoTo ErrPlace

    

    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET, _

                     tImageLayout)

    If (iRtn <> TWRC_SUCCESS) And (iRtn <> TWRC_CHECKSTATUS) Then GoTo ErrPlace

    

    SetImageSize = 0

    Exit Function

    

ErrPlace:

    SetImageSize = 1

End Function


Private Function TwainTransfer(ByRef blShowUI As Boolean, _

                               ByRef lDIBHandle As Long) As Long

                               

    Dim tUI As TW_USERINTERFACE

    Dim tPending As TW_PENDINGXFERS

    Dim lhDIB As Long

    Dim tEvent As TW_EVENT

    Dim tMSG As MSG

    Dim lRtn As Long

    Dim iRtn As Integer

    

    On Local Error GoTo ErrPlace

    

    '---------------------------------------------

    ' Set tUI.ShowUI to 1 (show UI) or 0 (hide UI)

    '---------------------------------------------

    With tUI

        .ShowUI = IIf(blShowUI = True, 1, 0)

        .ModalUI = 1

        .hParent = m_lHndMsgWin

    End With

    

    '----------------------------------------------

    ' Enable Data Source User Interface

    '   DG_CONTROL, DAT_USERINTERFACE, MSG_ENABLEDS

    '----------------------------------------------

    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _

                     MSG_ENABLEDS, tUI)

    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace

    

    '-----------------------------------------------------------------

    ' Process events in the message loop

    '   DG_CONTROL, DAT_EVENT, MSG_PROCESSEVENT

    '

    ' There are two messages we are interested in in this message loop

    '   - MSG_XFERREADY - the data source is ready to transfer

    '   - MSG_CLOSEDSREQ - the data source requests to close itself

    '-----------------------------------------------------------------

    While GetMessage(tMSG, 0&, 0&, 0&)

        Call ZeroMemory(VarPtr(tEvent), Len(tEvent))

        tEvent.pEvent = VarPtr(tMSG)

        iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_EVENT, _

                         MSG_PROCESSEVENT, tEvent)

        Select Case tEvent.TWMessage

            Case MSG_XFERREADY

                GoTo MSGGET

            Case MSG_CLOSEDSREQ

                GoTo MSGDISABLEDS

        End Select

        lRtn = TranslateMessage(tMSG)

        lRtn = DispatchMessage(tMSG)

    Wend

    

MSGGET:

    '----------------------------------------------------

    ' Start transfer

    '   DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET

    '

    ' If transfer is successful you get the handle to DIB

    '----------------------------------------------------

    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGENATIVEXFER, _

                     MSG_GET, lhDIB)

    If iRtn <> TWRC_XFERDONE Then

        iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_PENDINGXFERS, _

                         MSG_ENDXFER, tPending)

        iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _

                         MSG_DISABLEDS, tUI)

        GoTo ErrPlace

    End If

    

    '--------------------------------------------

    ' End transfer

    '   DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER

    '--------------------------------------------

    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_PENDINGXFERS, _

                     MSG_ENDXFER, tPending)

    If iRtn <> TWRC_SUCCESS Then

        iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _

                         MSG_DISABLEDS, tUI)

        GoTo ErrPlace

    End If

    

MSGDISABLEDS:

    '-----------------------------------------------

    ' Disable Data Source

    '   DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS

    '-----------------------------------------------

    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _

                     MSG_DISABLEDS, tUI)

    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace


    lDIBHandle = lhDIB

    TwainTransfer = 0

    Exit Function

    

ErrPlace:

    If lhDIB Then lRtn = GlobalFree(lhDIB)

    lDIBHandle = 0

    TwainTransfer = 1

End Function


Private Function SaveDIBToFile(ByRef lhDIB As Long, _

                               ByRef sFileName As String) As Long

    

    '---------------------------------------------------------------------------

    ' Function saves the handle to DIB (device independent bitmap) into BMP file

    '---------------------------------------------------------------------------


    Dim tBFH As BITMAPFILEHEADER

    Dim tBIH As BITMAPINFOHEADER

    Dim tRGB As RGBQUAD

    Dim lpDIB As Long

    Dim lDIBSize As Long

    Dim bDIBits() As Byte

    Dim iFileNum As Integer

    Dim lRtn As Long

    

    On Local Error GoTo ErrPlace

    

    If sFileName = "" Then GoTo ErrPlace

    

    If Dir(sFileName, vbNormal Or vbHidden Or vbSystem) <> "" Then

        Call SetAttr(sFileName, vbNormal)

        Call Kill(sFileName)

    End If

    

    lpDIB = GlobalLock(lhDIB)

    If lpDIB = 0 Then GoTo ErrPlace

    

    Call CopyMemory(VarPtr(tBIH), lpDIB, Len(tBIH))

    

    lDIBSize = Len(tBIH) + (tBIH.biClrUsed * Len(tRGB)) + _

               (((tBIH.biWidth * tBIH.biBitCount + 31) \ 32) * 4 * tBIH.biHeight)

    ReDim bDIBits(1 To lDIBSize) As Byte

    Call CopyMemory(VarPtr(bDIBits(1)), lpDIB, lDIBSize)

    

    lRtn = GlobalUnlock(lhDIB)

    lRtn = GlobalFree(lhDIB)

    lhDIB = 0

    

    With tBFH

        .bfType = 19778     ' "BM"

        .bfSize = Len(tBFH) + lDIBSize

        .bfOffBits = Len(tBFH) + Len(tBIH) + (tBIH.biClrUsed * Len(tRGB))

    End With

    iFileNum = FreeFile

    Open sFileName For Binary As #iFileNum

        Put #iFileNum, , tBFH

        Put #iFileNum, , bDIBits()

    Close #iFileNum

    

    SaveDIBToFile = 0

    Exit Function

    

ErrPlace:

    lRtn = GlobalUnlock(lhDIB)

    lRtn = GlobalFree(lhDIB)

    lhDIB = 0

    SaveDIBToFile = 1

End Function


Private Function TwainSetOneValue(ByVal Cap As TWAIN_MDL_CAPABILITY, _

                                  ByVal ItemType As TWAIN_MDL_ITEMYPE, _

                                  ByRef Item As Variant) As Long


    '-----------------------------------------------------------------------

    ' There are four types of containers that TWAIN defines for capabilities

    ' (TW_ONEVALUE, TW_ARRAY, TW_RANGE and TW_ENUMERATION)

    ' This module deals with one of them only - TW_ONEVALUE (single value)

    ' To set some capability you have to fill TW_ONEVALUE fields and use

    '   the triplet DG_CONTROL DAT_CAPABILITY MSG_SET

    ' The macros that convert some data types are used here as well

    '-----------------------------------------------------------------------

    On Local Error GoTo ErrPlace

    

    Dim tCapability As TW_CAPABILITY

    Dim tOneValue As TW_ONEVALUE

    Dim lhOneValue As Long

    Dim lpOneValue As Long

    Dim lRtn As Long

    Dim iRtn As Integer

    Dim tFix32 As TW_FIX32

    Dim iTmp As Integer


    tCapability.ConType = TWON_ONEVALUE

    tCapability.Cap = Cap

    

    tOneValue.ItemType = ItemType

    

    Select Case ItemType

        Case INT16

            tOneValue.Item1 = CInt(Item)

        Case UINT16, BOOL

            If ToUnsignedShort(CLng(Item), iTmp) Then GoTo ErrPlace

            Call CopyMemory(VarPtr(tOneValue.Item1), VarPtr(iTmp), 2&)

        Case FIX32

            If FloatToFix32(CSng(Item), tFix32) Then GoTo ErrPlace

            Call CopyMemory(VarPtr(tOneValue.Item1), VarPtr(tFix32), 4&)

    End Select


    lhOneValue = GlobalAlloc(GHND, Len(tOneValue))

    lpOneValue = GlobalLock(lhOneValue)

    Call CopyMemory(lpOneValue, VarPtr(tOneValue), Len(tOneValue))

    lRtn = GlobalUnlock(lhOneValue)

    tCapability.hContainer = lhOneValue


    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, _

                     tCapability)

    If iRtn <> TWRC_SUCCESS Then

        lRtn = GlobalFree(lhOneValue)

        GoTo ErrPlace

    End If

    lRtn = GlobalFree(lhOneValue)


    TwainSetOneValue = 0

    Exit Function


ErrPlace:

    TwainSetOneValue = 1

End Function


Private Function TwainGetOneValue(ByVal Cap As TWAIN_MDL_CAPABILITY, _

                                  ByRef Item As Variant) As Long


    '-----------------------------------------------------------------------

    ' There are four types of containers that TWAIN defines for capabilities

    ' (TW_ONEVALUE, TW_ARRAY, TW_RANGE and TW_ENUMERATION)

    ' This module deals with one of them only - TW_ONEVALUE (single value)

    ' To get some capability you have to fill TW_ONEVALUE fields and use

    '   the triplet DG_CONTROL DAT_CAPABILITY MSG_GET

    ' The macros that convert some data types are used here as well

    '-----------------------------------------------------------------------

    

    On Local Error GoTo ErrPlace

    

    Dim tCapability As TW_CAPABILITY

    Dim tOneValue As TW_ONEVALUE

    Dim tFix32 As TW_FIX32

    Dim lpOneValue As Long

    Dim lRtn As Long

    Dim iRtn As Integer


    tCapability.ConType = TWON_ONEVALUE

    tCapability.Cap = Cap

    

    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, _

                     tCapability)

    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace

    

    lpOneValue = GlobalLock(tCapability.hContainer)

    Call CopyMemory(VarPtr(tOneValue), lpOneValue, Len(tOneValue))

    lRtn = GlobalUnlock(tCapability.hContainer)

    lRtn = GlobalFree(tCapability.hContainer)


    Select Case tOneValue.ItemType

        Case INT16

            Item = tOneValue.Item1

        Case UINT16, BOOL

            Item = FromUnsignedShort(tOneValue.Item1)

        Case FIX32

            Call CopyMemory(VarPtr(tFix32), VarPtr(tOneValue.Item1), 4&)

            Item = Fix32ToFloat(tFix32)

    End Select

    

    TwainGetOneValue = 0

    Exit Function


ErrPlace:

    TwainGetOneValue = 1

End Function


Private Function ToUnsignedShort(ByRef lSrc As Long, _

                                 ByRef iDst As Integer) As Long

    

    '------------------------------------------------------------------------

    ' Sets number ranging from 0 to 65535 into 2-byte VB Integer

    ' (useful for communicating with other dll that uses unsigned data types)

    '

    ' Function returns 0 is OK, 1 if an error occurs

    '------------------------------------------------------------------------

    

    On Local Error GoTo ErrPlace

    

    If (lSrc < 0) Or (lSrc > 65535) Then GoTo ErrPlace

    

    Call CopyMemory(VarPtr(iDst), VarPtr(lSrc), 2&)

    

    ' Another way

    'iDst = IIf(lSrc > 32767, lSrc - 65536, lSrc)

    

    ToUnsignedShort = 0

    Exit Function

    

ErrPlace:

    ToUnsignedShort = 1

End Function


Private Function FromUnsignedShort(ByRef iSrc As Integer) As Long


    '------------------------------------------------------------------------

    ' Gets the 2-byte unsigned number from VB Integer data type

    ' (useful for communicating with other dll that uses unsigned data types)

    '

    ' Function returns unsigned 2-byte value (in VB Long type)

    '------------------------------------------------------------------------

    

    Dim lTmp As Long

    

    Call CopyMemory(VarPtr(lTmp), VarPtr(iSrc), 2&)

    

    ' Another way

    'lTmp = IIf(iSrc < 0, iSrc + 65536, iSrc)

    

    FromUnsignedShort = lTmp


End Function


Private Function ToUnsignedLong(ByRef sngSrc As Single, _

                                ByRef lDst As Long) As Long


    '------------------------------------------------------------------------

    ' Sets number ranging from 0 to 4294967295 into 4-byte VB Long

    ' (useful for communicating with other dll that uses unsigned data types)

    '

    ' Function returns 0 is OK, 1 if an error occurs

    '------------------------------------------------------------------------


    On Local Error GoTo ErrPlace

    

    If (sngSrc < 0) Or (sngSrc > 4294967295#) Then GoTo ErrPlace

    

    lDst = IIf(sngSrc > 2147483647, sngSrc - 4294967296#, sngSrc)

    

    ToUnsignedLong = 0

    Exit Function

    

ErrPlace:

    ToUnsignedLong = 1

End Function


Private Function FromUnsignedLong(ByRef lSrc As Long) As Single


    '------------------------------------------------------------------------

    ' Gets the 4-byte unsigned number from VB Long data type

    ' (useful for communicating with other dll that uses unsigned data types)

    '

    ' Function returns unsigned 4-byte value (in VB Single type)

    '------------------------------------------------------------------------


    Dim sngTmp As Single

    

    sngTmp = IIf(lSrc < 0, lSrc + 4294967296#, lSrc)

    FromUnsignedLong = sngTmp


End Function


Private Function Fix32ToFloat(ByRef tFix32 As TW_FIX32) As Single

        

    '----------------------------------------------------------------

    ' Converts TWAIN TW_FIX32 data structure into VB Single data type

    ' (needed for communicating with TWAIN)

    '

    ' Function returns floating-point number in VB Single data type

    '----------------------------------------------------------------

        

    Dim sngTmp As Single

    

    sngTmp = tFix32.Whole + CSng(FromUnsignedShort(tFix32.Frac) / 65536)

    Fix32ToFloat = sngTmp


End Function


Private Function FloatToFix32(ByRef sngSrc As Single, _

                              ByRef tFix32 As TW_FIX32) As Long

    

    '----------------------------------------------------------------

    ' Converts VB Single data type into TWAIN TW_FIX32 data structure

    ' (needed for communicating with TWAIN)

    '

    ' Function returns 0 is OK, 1 if an error occurs

    '----------------------------------------------------------------

    

    On Local Error GoTo ErrPlace

    

    tFix32.Whole = CInt(Fix(sngSrc))

    Call ToUnsignedShort(CLng(sngSrc * 65536) And 65535, tFix32.Frac)

    FloatToFix32 = 0

    Exit Function


ErrPlace:

    FloatToFix32 = 1

End Function


发布人:zstmtony  
分享到:
点击次数:  更新时间:2017-02-05 14:47:36  【打印此页】  【关闭】
上一条:TWAIN驱动介绍-Access使用扫描仪必学  下一条:C#调用WIA对扫描仪进行开发编程



相关文章

  • • Access 获取图片的像素
  • • Access在同一页面中调用多张图片及放大图片
  • • 解决“我的电脑”中不显示扫描仪和摄像头
  • • WIA的脚本和NET(扫描仪开发)
  • • 可用来连接扫描仪的国外第三方免费控件Accessing TWAIN compatible scanner in Visual Basic
  • • 如何共享扫描仪
  • • 扫描程序设计说明文档(twain_32调用说明)
  • • Delphi针对扫描仪编程开发的相关代码

热门文章

  • [2017-02-05] Delphi针对扫描仪编程开发的相关代码access数据库
  • [2017-02-05] TWAIN驱动介绍-Access使用扫描仪必学access数据库
  • [2017-02-05] Access VBA多种调用扫描仪的方案access数据库
  • [2017-02-06] 如何共享扫描仪access数据库
  • [2017-02-06] 可用来连接扫描仪的国外第三方免费控件Accessing TWAIN compatible scanner in Visual Basicaccess数据库
  • [2017-02-05] TWAIN和WIA扫描仪的功能区别access数据库

热门产品

公司动态|在线留言|在线反馈|友情链接|会员中心|站内搜索|网站地图

Access交流网 版权所有 1999-2018 粤ICP备10043721号

QQ:18449932

Access应用 Access培训 Access开发 Access平台

access|数据库|access下载|access教程|access视频|access软件

Powered by MetInfo 5.3.12 ©2008-2023  www.metinfo.cn