📄 frmimgscan.frm
字号:
VERSION 5.00
Object = "{84926CA3-2941-101C-816F-0E6013114B7F}#1.0#0"; "imgscan.ocx"
Begin VB.Form frmImgScan
BorderStyle = 3 'Fixed Dialog
Caption = "从输入设备导入(扫描仪、数码相机)"
ClientHeight = 4515
ClientLeft = 45
ClientTop = 330
ClientWidth = 7560
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4515
ScaleWidth = 7560
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin ScanLibCtl.ImgScan ImgScan
Left = 3660
Top = 2400
_Version = 65536
_ExtentX = 873
_ExtentY = 873
_StockProps = 0
DestImageControl= "ImgEdit1"
ScanTo = 1
End
Begin VB.CommandButton cmdPrevious
Caption = "< 上一页(&P)"
Height = 375
Left = 750
TabIndex = 7
Top = 3900
Width = 1300
End
Begin VB.CommandButton cmdNext
Caption = "下一页(&N) >"
Height = 375
Left = 2070
TabIndex = 4
Top = 3900
Width = 1300
End
Begin VB.CommandButton cmdSave
Caption = " 扫描(&S)"
Height = 375
Left = 4185
TabIndex = 3
Top = 3900
Width = 1500
End
Begin VB.CommandButton cmdExit
Caption = " 退出(&E)"
Height = 375
Left = 5700
TabIndex = 2
Top = 3900
Width = 1500
End
Begin VB.Frame frmImgScan
Caption = "当前导入"
Height = 3495
Left = 90
TabIndex = 0
Top = 90
Width = 7365
Begin VB.ComboBox cmbImgSavePath
Height = 300
Left = 270
TabIndex = 9
Top = 2850
Width = 3225
End
Begin VB.CommandButton cmdSeleDevice
Caption = "选择设备"
Height = 375
Left = 5610
TabIndex = 6
Top = 2820
Width = 1300
End
Begin VB.CommandButton cmdCompress
Caption = "压缩类型"
Height = 375
Left = 4290
TabIndex = 5
Top = 2820
Width = 1300
End
Begin VB.Label lblImgSavePath
AutoSize = -1 'True
Caption = "扫描所得文书存放路径"
Height = 180
Left = 270
TabIndex = 8
Top = 2520
Width = 1800
End
Begin VB.Label lblCaption
BorderStyle = 1 'Fixed Single
Caption = "Label1"
Height = 1815
Left = 240
TabIndex = 1
Top = 330
Width = 6915
End
End
End
Attribute VB_Name = "frmImgScan"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public IsSave As Boolean
Public Img_SSSQ As String
Dim mbSkip As Boolean
Private Sub cmdCompress_Click()
ImgScan.ShowScanPreferences
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub CmdNext_Click()
Call RefreshCaption(lblCaption, CmdNext, CmdPrevious, True)
End Sub
Private Sub CmdPrevious_Click()
Call RefreshCaption(lblCaption, CmdNext, CmdPrevious, False)
End Sub
Private Sub cmdSave_Click()
Call StartScan
End Sub
Private Sub cmdSeleDevice_Click()
ImgScan.ShowSelectScanner
End Sub
Private Sub StartScan()
'********************************************************************
'过程功能：将扫描仪扫入的图片导入系统数据库(sys_Image)
'扫描由 nComp ,nCase ,nPage 决定的某企业的某种文书
'步骤如下:
' 1. 检测扫描仪,如不存在或未打开,则提示用户,并退出
' 2. 检查该企业的该种文书是否已存在,如存在,则提示是否覆盖,Yes 则删除库中的旧纪录,然后继续,No 则跳到第 9 步
' 3. 从cmbImgSavePath.Text取得文件存放路径
' 4. 生成文件路径+名称,名称取当前时间-- XXXX年XX月XX日XX时XX分XX秒.TIF (如 19990415210100.TIF)
' 5. 扫描
' 6. 显示frmImgPreview,在ImgEdit中显示扫描所得图像
' 7. 由用户指定该图片所属时期(如果有时间属性),并保存该所属时期,便于在下一次扫描时调用
' 8. 保存该图片(将图片信息存入数据库)
' 9. 通过调用RefreshCaption(True),递增 nComp, nCase, nPage
' 10.结束
'********************************************************************
On Error GoTo ErrorHandler
Dim Msg As String
Dim strTemp As String
Dim OverWrite As Boolean
Dim rstCompany As ADODB.Recordset
Dim rstCase As ADODB.Recordset
Dim fImgPreview As frmImgPreview
'检测扫描接口程序
If Not ImgScan.ScannerAvailable Then
MsgBox "系统未检测到任何 Twain兼容 的扫描设备"
Exit Sub
End If
ImgScan.GetCompressionPreference
'检查该图片信息是否已存在,如存在,则进行处理
With CompanyCaseType(CompNum, CaseNum)
If ImageExisted(CompanyCaseType(CompNum, CaseNum)) Then
strTemp = "企业名称: " & .Nsrmc & vbCrLf & _
"企业编码: " & .QYBM & vbCrLf & _
"文书名称: " & .Case_Name & vbCrLf & _
"所属时期: " & .Img_SSSQ & vbCrLf & _
"已经存在, 是否覆盖?"
Msg = MsgBox(strTemp, vbYesNo + vbInformation)
Select Case Msg
Case vbYes
'OverWrite = True
Case vbNo
MsgBox "请重新选择企业、文书或所属时期", vbInformation
Exit Sub
End Select
End If
End With
'生成文件名称
If Dir(cmbImgSavePath.Text, vbDirectory) = vbNullString Then
MkDir (cmbImgSavePath.Text)
End If
If Right(Trim(cmbImgSavePath.Text), 1) <> "\" Then
CompanyCaseType(CompNum, CaseNum).Img_Path = cmbImgSavePath.Text & "\"
Else
CompanyCaseType(CompNum, CaseNum).Img_Path = cmbImgSavePath.Text
End If
CompanyCaseType(CompNum, CaseNum).Img_Name = Year(Date) & _
Format(DatePart("M", Date), "0#") & _
Format(DatePart("D", Date), "0#") & _
Format(Hour(Time), "0#") & _
Format(Minute(Time), "0#") & _
Format(Second(Time), "0#") & ".tif"
'扫描
ImgScan.Image = CompanyCaseType(CompNum, CaseNum).Img_Path & CompanyCaseType(CompNum, CaseNum).Img_Name
ImgScan.OpenScanner
ImgScan.StartScan
If Dir(CompanyCaseType(CompNum, CaseNum).Img_Path & CompanyCaseType(CompNum, CaseNum).Img_Name) = vbNullString Then
MsgBox "扫描仪或数码相机未准备好,请准备好以后重试!", vbInformation
Exit Sub
End If
'显示frmImgPreview,如果是非登记类文书,则取得所属时期
Set fImgPreview = New frmImgPreview
fImgPreview.Show vbModal
'存盘
If fImgPreview.IsSave = True Then
CompanyCaseType(CompNum, CaseNum).Img_ImportDate = Format(Date, "Long Date")
If CompanyCaseType(CompNum, CaseNum).Img_IsRegister = False Then
CompanyCaseType(CompNum, CaseNum).Img_SSSQ = fImgPreview.Img_SSSQ
End If
If ImageExisted(CompanyCaseType(CompNum, CaseNum)) Then
If DeleteImage(CompanyCaseType(CompNum, CaseNum)) = False Then
MsgBox "删除原有文书信息错误,取消保存!", vbCritical
Exit Sub
End If
End If
If SaveImage(CompanyCaseType(CompNum, CaseNum)) Then
MsgBox "存盘成功!", vbInformation
Else
MsgBox "存盘失败,请检查原因,记下文件名称,以便通过[文件导入]重新导入!" & _
vbCrLf & "文件名称: " & CompanyCaseType(CompNum, CaseNum).Img_Name, vbCritical
End If
Else
End If
'Move to 下一张文书
Call RefreshCaption(lblCaption, CmdNext, CmdPrevious, True)
Exit Sub
ErrorHandler:
If Err Then
MsgBox Err.Description, vbCritical
Err.Clear
End If
End Sub
Private Sub Form_Activate()
Call RefreshCaption(lblCaption, CmdNext, CmdPrevious, False)
End Sub
Private Sub Form_Load()
Dim rstImgPath As ADODB.Recordset
Set rstImgPath = New ADODB.Recordset
rstImgPath.Open "SELECT Img_Path FROM Sys_Path", conCaseMain, 1, 1 ', adCmdText
With rstImgPath
If Not .EOF Then .MoveLast
If Not .BOF Then .MoveFirst
Do Until .EOF
If !Img_Path <> vbNullString Then
cmbImgSavePath.AddItem !Img_Path
End If
.MoveNext
Loop
End With
cmbImgSavePath.Text = cmbImgSavePath.List(0)
rstImgPath.Close
End Sub
Private Sub Form_Unload(Cancel As Integer)
'ReDim CompanyCaseType(0)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -