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
