1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
| 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 |
(
