📄 frmimgcopy.frm
字号:
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Object = "{6D940288-9F11-11CE-83FD-02608C3EC08A}#2.2#0"; "imgedit.ocx"
Begin VB.Form frmImgCopy
BorderStyle = 3 'Fixed Dialog
Caption = "导入现存图片预览"
ClientHeight = 7125
ClientLeft = 2280
ClientTop = 1485
ClientWidth = 8205
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 7125
ScaleWidth = 8205
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin ImgeditLibCtl.ImgEdit ImgEdit
Height = 4275
Left = 120
TabIndex = 14
Top = 2760
Width = 5175
_Version = 131074
_ExtentX = 9128
_ExtentY = 7541
_StockProps = 96
BorderStyle = 1
ImageControl = "ImgEdit1"
BeginProperty AnnotationFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Times New Roman"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
UndoBufferSize = 45459968
OcrZoneVisibility= -4088
AnnotationOcrType= 25649
ForceFileLinking1x= -1 'True
MagnifierZoom = 25649
sReserved1 = -4088
sReserved2 = -4088
lReserved1 = 5814058
lReserved2 = 5814058
bReserved1 = -1 'True
bReserved2 = -1 'True
End
Begin MSComCtl2.UpDown UpDown1
Height = 285
Left = 7650
TabIndex = 13
Top = 1800
Width = 240
_ExtentX = 450
_ExtentY = 503
_Version = 393216
Enabled = -1 'True
End
Begin VB.Frame frmImgCopy
Caption = "当前复制"
Height = 2625
Left = 120
TabIndex = 3
Top = 60
Width = 7995
Begin VB.CommandButton cmdPrevious
Caption = "< 上一页(&P)"
Height = 375
Left = 1500
TabIndex = 10
Top = 2160
Width = 1300
End
Begin VB.CommandButton cmdSave
Caption = " 保存(&S)"
Height = 375
Left = 5160
TabIndex = 9
Top = 2160
Width = 1300
End
Begin VB.TextBox txtSSSQ
Height = 315
Left = 6210
MaxLength = 6
TabIndex = 8
Text = "SSSQ"
Top = 1740
Width = 1305
End
Begin VB.CommandButton cmdNext
Caption = " 下一页(&N) > "
Height = 375
Left = 2820
TabIndex = 6
Top = 2160
Width = 1300
End
Begin VB.CommandButton CmdCancel
Caption = " 取消(&C)"
Height = 375
Left = 6480
TabIndex = 5
Top = 2160
Width = 1300
End
Begin VB.ComboBox cmbImgSavePath
Height = 300
Left = 1770
TabIndex = 11
Text = "Combo1"
Top = 1740
Width = 3285
End
Begin VB.Label lblSSSQ
AutoSize = -1 'True
Caption = "所属时期"
Height = 180
Left = 5370
TabIndex = 7
Top = 1815
Width = 720
End
Begin VB.Label lblCaption
BorderStyle = 1 'Fixed Single
Caption = "Label1"
Height = 1365
Left = 240
TabIndex = 4
Top = 270
Width = 7545
End
Begin VB.Label lblImgSavePath
AutoSize = -1 'True
Caption = "复制文书存放路径"
Height = 180
Left = 240
TabIndex = 12
Top = 1800
Width = 1440
End
End
Begin VB.CommandButton CmdGetImgPath
Caption = "浏览(&B)"
Height = 350
Left = 6810
TabIndex = 0
Top = 3180
Width = 1300
End
Begin VB.TextBox txtImgPath
Height = 350
Left = 5400
TabIndex = 2
Top = 2790
Width = 2700
End
Begin VB.FileListBox File
Height = 3330
Left = 5400
Pattern = "*.bmp;*.tif;*.jpg"
TabIndex = 1
Top = 3540
Width = 2700
End
End
Attribute VB_Name = "frmImgCopy"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim ListCount As Integer 'frmFileImport中选定目录下的图片数量
Public intIndex As Integer '当前显示的图片索引号
Dim ZoomBefore As Integer '图像缩放前的zoom值
Dim StartX As Single '鼠标在图像中单击的x坐标
Dim StartY As Single '鼠标在图像中单击的y坐标
Dim ZoomX As Single 'ImgEdit控件宽度与显示图像宽度的比值
Dim ZoomY As Single 'ImgEdit控件高度与显示图像高度的比值
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub CmdGetImgPath_Click()
frmFindPath.Tag = "ImgCopy"
frmFindPath.Show vbModal
txtImgPath.Text = frmFindPath.ThisPath
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 StartCopy
End Sub
Private Sub File_Click()
ImgEdit.ClearDisplay
ImgEdit.Image = File.Path & "\" & File.FileName
'将显示的图片缩放到到适合ImgEdit控件的高度和宽度
ZoomX = (ImgEdit.Width / 15.5) / ImgEdit.ImageWidth
ZoomY = (ImgEdit.Height / 15.5) / ImgEdit.ImageHeight
If ZoomX > ZoomY Then
ImgEdit.Zoom = ZoomY * 100
Else
ImgEdit.Zoom = ZoomX * 100
End If
ImgEdit.Display
intIndex = File.ListIndex
End Sub
Private Sub Form_Activate()
Call CmdPrevious_Click
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, adOpenStatic, adLockOptimistic, 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
Call RefreshCaption(lblCaption, cmdNext, cmdPrevious, False)
File.Path = "c:\windows\"
File.Path = GetSetting(App.Title, "Settings", "FilePath", "c:\windows\")
txtSSSQ.Text = Year(Date) & Format(DatePart("M", Date), "0#")
txtSSSQ.Text = GetSetting(App.Title, "Settings", "txtSSSQ", txtSSSQ.Text)
txtImgPath.Text = GetSetting(App.Title, "Settings", "ImgPath", App.Path)
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.Title, "Settings", "txtSSSQ", txtSSSQ.Text
SaveSetting App.Title, "Settings", "ImgPath", txtImgPath.Text
End Sub
Private Sub ImgEdit_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
StartX = X
StartY = Y
End Sub
Private Sub ImgEdit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'******************************
'功能: 缩放鼠标选取范围内的图像
'******************************
On Error GoTo ErrorHandler
If StartX = X And StartY = Y And ZoomBefore <> 0 Then
ImgEdit.Display
ImgEdit.Zoom = ZoomBefore
ImgEdit.Refresh
End If
If (StartX / 20) < ImgEdit.ImageScaleWidth And (StartY / 20) < ImgEdit.ImageScaleHeight Then
If StartX <> X And StartY <> Y Then
If ((Abs((StartX - X)) / 20) * 25) > ImgEdit.ImageScaleWidth And _
((Abs((StartY - Y)) / 20) * 25) > ImgEdit.ImageScaleHeight Then
ZoomBefore = ImgEdit.Zoom
ImgEdit.ZoomToSelection
End If
End If
End If
Exit Sub
ErrorHandler:
If Err Then
Err.Clear
End If
End Sub
Private Sub txtImgPath_Change()
If Dir(txtImgPath, vbDirectory) <> vbNullString Then
File.Path = txtImgPath.Text
End If
End Sub
Private Sub StartCopy()
'********************************************************************
'过程功能：将现有的图片文件导入系统数据库(sys_Image)
'扫描由 nComp ,nCase ,nPage 决定的某企业的某种文书
'步骤如下:
' 1. 检查该企业的该种文书是否已存在,如存在,则提示是否覆盖,Yes 则删除库中的旧纪录,然后继续,No 则跳到第 6 步
' 2. 从cmbImgSavePath.Text取得文件存放路径
' 3. 生成文件路径+名称,名称取当前时间-- XXXX年XX月XX日XX时XX分XX秒.TIF (如 19990415210100.TIF)
' 4. 复制文件
' 5. 保存该图片(将图片信息存入数据库)
' 6. 通过调用RefreshCaption(True),递增 nComp, nCase, nPage
' 7. 结束
'********************************************************************
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 File.List(File.ListIndex) = vbNullString Then
MsgBox "请在文件列表框中选择一个文件!", vbInformation
File.SetFocus
Exit Sub
End If
If cmbImgSavePath.Text = vbNullString Then
MsgBox "请在文书存放路径列表中选择一个路径!", vbInformation
cmbImgSavePath.SetFocus
Exit Sub
End If
'Debug
CompanyCaseType(CompNum, CaseNum).Img_Current_Page = PageNum + 1
'检查该图片信息是否已存在,如存在,则进行处理
With CompanyCaseType(CompNum, CaseNum)
If ImageExisted(CompanyCaseType(CompNum, CaseNum)) Then
strTemp = "企业名称: " & .Nsrmc & vbCrLf & _
"企业编码: " & .QYBM & vbCrLf & _
"文书名称: " & .Case_Name & vbCrLf & _
"所属时期: " & .Img_SSSQ & vbCrLf & _
"页 码: " & .Img_Current_Page & 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(Month(Date), "0#") & _
Format(Day(Date), "0#") & _
Format(Hour(Time), "0#") & _
Format(Minute(Time), "0#") & _
Format(Second(Time), "0#") & _
Right(File.List(File.ListIndex), 4)
'如果是非登记类文书,则取得所属时期
If CompanyCaseType(CompNum, CaseNum).Img_IsRegister = False Then
If IsDate(Left(txtSSSQ.Text, 4) & "/" & Right(txtSSSQ.Text, 2)) Then
CompanyCaseType(CompNum, CaseNum).Img_SSSQ = txtSSSQ.Text
End If
End If
'导入日期
CompanyCaseType(CompNum, CaseNum).Img_ImportDate = Format(Date, "Long Date")
'复制文件
FileCopy File.Path & "\" & File.List(File.ListIndex), CompanyCaseType(CompNum, CaseNum).Img_Path & CompanyCaseType(CompNum, CaseNum).Img_Name
'存盘
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
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 UpDown1_DownClick()
Dim tmpDate As String
tmpDate = DateValue(Left(txtSSSQ, 4) & "/" & Right(txtSSSQ, 2) & "/01")
txtSSSQ.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub
Private Sub UpDown1_UpClick()
Dim tmpDate As String
tmpDate = DateValue(Left(txtSSSQ, 4) & "/" & Right(txtSSSQ, 2) & "/01")
txtSSSQ.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -