' TWAIN계열의 스캐너(scanner)를 컨트롤하는 모듈

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_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_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

Private Const ICAP_PIXELTYPE = 257
Private Const ICAP_PHYSICALWIDTH = 4369
Private Const ICAP_PHYSICALHEIGHT = 4370
Private Const ICAP_XRESOLUTION = 4376
Private Const ICAP_YRESOLUTION = 4377
Private Const ICAP_BITDEPTH = 4395

Private Const CAP_XFERCOUNT = 1
Private Const CAP_INDICATORS = 4107
Private Const CAP_UICONTROLLABLE = 4110

Private Const TWPT_BW = 0
Private Const TWPT_GRAY = 1
Private Const TWPT_RGB = 2

Private Const TWTY_INT16 = 1
Private Const TWTY_UINT16 = 4
Private Const TWTY_BOOL = 6
Private Const TWTY_FIX32 = 7


 '-------------------------
 ' 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 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 iRtn As Integer
    
     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
         .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 Class", vbFromUnicode)), _
                     Len( "VB Class"))
     Call CopyMemory(VarPtr(m_tAppID.ProductName(1)), _
                     StrPtr(StrConv( "VB Class for TWAIN", vbFromUnicode)), _
                     Len( "VB Class for TWAIN"))
    
     Call ZeroMemory(VarPtr(m_tSrcID), Len(m_tSrcID))
    
     iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_OPENDSM, m_lHndMsgWin)
     If iRtn Then GoTo ErrPlace
    
     iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, MSG_OPENDS, m_tSrcID)
     If iRtn Then
         iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM, m_lHndMsgWin)
         GoTo ErrPlace
     End If
    
     OpenTwain = 0
     Exit Function
    
ErrPlace:
     OpenTwain = 1
End Function

Private Function CloseTwain() As Long
     Dim iRtn As Integer
    
     On Local Error GoTo ErrPlace
    
     iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, MSG_CLOSEDS, m_tSrcID)
     If iRtn Then
         iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM, m_lHndMsgWin)
         GoTo ErrPlace
     End If
    
     iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM, m_lHndMsgWin)
     If iRtn Then GoTo ErrPlace
    
     CloseTwain = 0
     Exit Function

ErrPlace:
     CloseTwain = 1
End Function

Private Function DoNotShowIndicators() As Long
     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
    
     On Local Error GoTo ErrPlace
    
     tCapability.ConType = TWON_ONEVALUE
     tCapability.Cap = CAP_INDICATORS
    
     '-----------------------
     ' tCapability.hContainer
     '-----------------------
     tOneValue.ItemType = TWTY_BOOL
     tOneValue.Item1 = 0
        
     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 Then
         lRtn = GlobalFree(lhOneValue)
         GoTo ErrPlace
     End If
    
     lRtn = GlobalFree(lhOneValue)
    
     DoNotShowIndicators = 0
     Exit Function
    
ErrPlace:
     DoNotShowIndicators = 1
End Function

Private Function IsUIControlable() As Long
     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
    
     On Local Error GoTo ErrPlace
    
     tCapability.ConType = TWON_ONEVALUE
     tCapability.Cap = CAP_UICONTROLLABLE
     iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, tCapability)
     If iRtn Then GoTo ErrPlace
    
     lpOneValue = GlobalLock(tCapability.hContainer)
     Call CopyMemory(VarPtr(tOneValue), lpOneValue, Len(tOneValue))
     lRtn = GlobalUnlock(tCapability.hContainer)
     lRtn = GlobalFree(tCapability.hContainer)
    
     If tOneValue.Item1 <> 1 Then GoTo ErrPlace
    
     IsUIControlable = 0
     Exit Function
    
ErrPlace:
     IsUIControlable = 1
End Function

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
     Dim iRtn As Integer
    
     On Local Error GoTo ErrPlace
    
     '----------------------------------------
     ' Get ICAP_PHYSICALWIDTH into TW_ONEVALUE
     '----------------------------------------
     tCapability.ConType = TWON_ONEVALUE
     tCapability.Cap = ICAP_PHYSICALWIDTH
     iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, tCapability)
     If iRtn 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
     iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, tCapability)
     If iRtn 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&)
     iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET, tImageLayout)
     If ((iRtn) And (iRtn <> 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
     Dim iRtn As Integer
    
     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
     '------------
     iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, tCapability)
     If iRtn 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
     '------------
     iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, tCapability)
     If iRtn Then
         lRtn = GlobalFree(lhOneValue)
         GoTo ErrPlace
     End If
     lRtn = GlobalFree(lhOneValue)
    
     SetResolution = 0
     Exit Function
    
ErrPlace:
     SetResolution = 1
End Function

Private Function SetColor() As Long
     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
    
     On Local Error GoTo ErrPlace
    
     tCapability.Cap = ICAP_PIXELTYPE
     tCapability.ConType = TWON_ONEVALUE
    
     '-----------------------
     ' tCapability.hContainer
     '-----------------------
     tOneValue.ItemType = TWTY_UINT16
     tOneValue.Item1 = m_ColourType
    
     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 Then
         lRtn = GlobalFree(lhOneValue)
         GoTo ErrPlace
     End If
    
     lRtn = GlobalFree(lhOneValue)
    
     SetColor = 0
     Exit Function
    
ErrPlace:
     SetColor = 1
End Function

Private Function SetBitDepth() As Long
     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
    
     On Local Error GoTo ErrPlace
    
     tCapability.Cap = ICAP_BITDEPTH
     tCapability.ConType = TWON_ONEVALUE
    
     '-----------------------
     ' tCapability.hContainer
     '-----------------------
     tOneValue.ItemType = TWTY_UINT16
     tOneValue.Item1 = 24 ' 24 bits
    
     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 Then
         lRtn = GlobalFree(lhOneValue)
         GoTo ErrPlace
     End If
    
     lRtn = GlobalFree(lhOneValue)
    
     SetBitDepth = 0
     Exit Function
    
ErrPlace:
     SetBitDepth = 1
End Function

Private Function SetNumberOfImages() As Long
     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
    
     On Local Error GoTo