Twain Dialog Scanner. Как с ним работать? - VB

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 Long, _
                                    ByVal MSG As Long, _
                                    ByRef pData As Any) As Long
 
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         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 Class
'---------------------------
Private m_tAppID As TW_IDENTITY
Private m_tSrcID As TW_IDENTITY
Private m_lHndMsgWin As Long
Private m_sImageName As String
Private m_ColourType As TWAIN_CLASS_COLOURTYPE
 
Public Enum TWAIN_CLASS_COLOURTYPE
    BW = 0
    GREY = 1
    RGB = 2
End Enum
 
Public Function ScanTwain(ByVal Resolution As Integer, ByVal ColourType As TWAIN_CLASS_COLOURTYPE, _
                          ByVal ImageName As String, ByVal ShowIndicators As Boolean) As Long
        
    Dim lRtn As Long
    
    On Local Error GoTo ErrPlace
    
    m_ColourType = ColourType
    m_sImageName = ImageName
    
    m_lHndMsgWin = CreateWindowEx(0&, '#32770', 'TWAIN_MSG_WINDOW', 0&, _
                                  10&, 10&, 150&, 50&, 0&, 0&, 0&, 0&)
    If m_lHndMsgWin = 0 Then GoTo ErrPlace
        
    If OpenTwain() Then
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If
    
    If ShowIndicators = False Then lRtn = DoNotShowIndicators()
 
    If IsUIControlable() Then
        lRtn = CloseTwain()
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If
 
    If SetMaxImageSize() Then
        lRtn = CloseTwain()
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If
 
    If SetResolution(Resolution) Then
        lRtn = CloseTwain()
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If
 
    If SetColor() Then
        lRtn = CloseTwain()
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If
 
    If ColourType = RGB Then lRtn = SetBitDepth()
    
    If SetNumberOfImages() Then
        lRtn = CloseTwain()
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If
 
    If Scan() Then
        lRtn = CloseTwain()
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If
 
    If CloseTwain() Then
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If
 
    If DestroyWindow(m_lHndMsgWin) = 0 Then GoTo ErrPlace
    
    ScanTwain = 0
    Exit Function
    
ErrPlace:
    ScanTwain = 1
End Function
 
Private Function OpenTwain() As Long
    Dim lRtn As Long
    
    On Local Error GoTo ErrPlace
    
    Call ZeroMemory(VarPtr(m_tAppID), Len(m_tAppID))
    
    With m_tAppID
        .Version.MajorNum = 1
        .Version.Language = TWLG_CZECH
        .Version.Country = TWCY_CZECHOSLOVAKIA  on
 
Private Function SetMaxImageSize() As Long
    Dim tCapability As TW_CAPABILITY
    Dim tOneValueWidth As TW_ONEVALUE
    Dim tOneValueHeight As TW_ONEVALUE
    Dim lpOneValue As Long
    Dim tImageLayout As TW_IMAGELAYOUT
    Dim lRtn As Long
    
    On Local Error GoTo ErrPlace
    
    '----------------------------------------
    ' Get ICAP_PHYSICALWIDTH into TW_ONEVALUE
    '----------------------------------------
    tCapability.ConType = TWON_ONEVALUE
    tCapability.Cap = ICAP_PHYSICALWIDTH
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, tCapability)
    If lRtn Then GoTo ErrPlace
    
    lpOneValue = GlobalLock(tCapability.hContainer)
    Call CopyMemory(VarPtr(tOneValueWidth), lpOneValue, Len(tOneValueWidth))
    lRtn = GlobalUnlock(tCapability.hContainer)
    lRtn = GlobalFree(tCapability.hContainer)
    
    '-----------------------------------------
    ' Get ICAP_PHYSICALHEIGHT into TW_ONEVALUE
    '-----------------------------------------
    tCapability.ConType = TWON_ONEVALUE
    tCapability.Cap = ICAP_PHYSICALHEIGHT
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, tCapability)
    If lRtn Then GoTo ErrPlace
    
    lpOneValue = GlobalLock(tCapability.hContainer)
    Call CopyMemory(VarPtr(tOneValueHeight), lpOneValue, Len(tOneValueHeight))
    lRtn = GlobalUnlock(tCapability.hContainer)
    lRtn = GlobalFree(tCapability.hContainer)
        
    '----------
    ' Set frame
    '----------
    Call CopyMemory(VarPtr(tImageLayout.Frame.Right), VarPtr(tOneValueWidth.Item1), 4&)
    Call CopyMemory(VarPtr(tImageLayout.Frame.Bottom), VarPtr(tOneValueHeight.Item1), 4&)
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET, tImageLayout)
    If ((lRtn) And (lRtn <> 2)) Then GoTo ErrPlace
    
    SetMaxImageSize = 0
    Exit Function
    
ErrPlace:
    SetMaxImageSize = 1
End Function
 
Private Function SetResolution(ByVal iRes As Integer) As Long
    Dim tCapability As TW_CAPABILITY
    Dim tOneValue As TW_ONEVALUE
    Dim lhOneValue As Long
    Dim lpOneValue As Long
    Dim lRtn As Long
    
    On Local Error GoTo ErrPlace
    
    tCapability.ConType = TWON_ONEVALUE
    tCapability.Cap = ICAP_XRESOLUTION
    
    '-----------------------
    ' tCapability.hContainer
    '-----------------------
    tOneValue.ItemType = TWTY_FIX32
    tOneValue.Item1 = iRes
        
    lhOneValue = GlobalAlloc(GHND, Len(tOneValue))
    lpOneValue = GlobalLock(lhOneValue)
    Call CopyMemory(lpOneValue, VarPtr(tOneValue), Len(tOneValue))
    lRtn = GlobalUnlock(lhOneValue)
    tCapability.hContainer = lhOneValue
    
    '------------
    ' XResolution
    '------------
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, tCapability)
    If lRtn Then
        lRtn = GlobalFree(lhOneValue)
        GoTo ErrPlace
    End If
    lRtn = GlobalFree(lhOneValue)
    
    Call ZeroMemory(VarPtr(tCapability), Len(tCapability))
    tCapability.ConType = TWON_ONEVALUE
    tCapability.Cap = ICAP_YRESOLUTION
    
    '-----------------------
    ' tCapability.hContainer
    '-----------------------
    tOneValue.ItemType = TWTY_FIX32
    tOneValue.Item1 = iRes
        
    lhOneValue = GlobalAlloc(GHND, Len(tOneValue))
    lpOneValue = GlobalLock(lhOneValue)
    Call CopyMemory(lpOneValue, VarPtr(tOneValue), Len(tOneValue))
    lRtn = GlobalUnlock(lhOneValue)
    tCapability.hContainer = lhOneValue
    
    '------------
    ' YResolution
    '------------
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, tCapability)
    If lRtn Then
        lRtn = Gl   With
    
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, MSG_ENABLEDS, tUI)
    If lRtn Then GoTo ErrPlace
    
    While GetMessage(tMSG, 0&, 0&, 0&)
        Call ZeroMemory(VarPtr(tEvent), Len(tEvent))
        tEvent.pEvent = VarPtr(tMSG)
        lRtn = 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:
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET, lhDIB)
    If lRtn <> TWRC_XFERDONE Then
        If lhDIB Then lRtn = GlobalFree(lhDIB)
        lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, tPending)
        lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS, tUI)
        GoTo ErrPlace
    End If
    
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER, tPending)
    If lRtn Then
        If lhDIB Then lRtn = GlobalFree(lhDIB)
        lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS, tUI)
        GoTo ErrPlace
    End If
    
    If SaveDibToFile(lhDIB) Then
        If lhDIB Then lRtn = GlobalFree(lhDIB)
        lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS, tUI)
        GoTo ErrPlace
    End If
    
MSGDISABLEDS:
    lRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS, tUI)
    If lRtn Then
        If lhDIB Then lRtn = GlobalFree(lhDIB)
        GoTo ErrPlace
    End If
 
    Scan = 0
    Exit Function
    
ErrPlace:
    Scan = 1
End Function
 
Private Function SaveDibToFile(ByRef lhDIB As Long) As Long
    Dim lpDIB As Long
    Dim tBIH As BITMAPINFOHEADER
    Dim tBFH As BITMAPFILEHEADER
    Dim tRGB As RGBQUAD
    Dim bDIBits() As Byte
    Dim lDIBSize As Long
    Dim iFileNum As Integer
    Dim lRtn As Long
    
    On Local Error GoTo ErrPlace
    
    If Dir(m_sImageName, vbNormal Or vbReadOnly Or vbHidden Or vbSystem) <> '' Then
        Call SetAttr(m_sImageName, vbNormal)
        Call Kill(m_sImageName)
    End If
    
    lpDIB = GlobalLock(lhDIB)
    If lpDIB = 0 Then GoTo ErrPlace
    
    Call CopyMemory(VarPtr(tBIH), lpDIB, Len(tBIH))
    
    Select Case m_ColourType
        Case BW
            tBIH.biClrUsed = 2
        Case GREY
            tBIH.biClrUsed = 256
        Case RGB
            tBIH.biClrUsed = 0
    End Select
    
    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)
    If GlobalFree(lhDIB) = 0 Then 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 m_sImageName For Binary As #iFileNum
        Put #iFileNum, , tBFH
        Put #iFileNum, , bDIBits()
    Close #iFileNum
    
    SaveDibToFile = 0
    Exit Function
    
ErrPlace:
    SaveDibToFile = 1
End Function