📄 imagebrowser.ctl
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{1BE65FA0-CBF9-11D2-BBC7-00104B9E0792}#2.0#0"; "sstbars2.ocx"
Begin VB.UserControl ImageBrowserControl
ClientHeight = 4455
ClientLeft = 0
ClientTop = 0
ClientWidth = 5835
LockControls = -1 'True
ScaleHeight = 4455
ScaleWidth = 5835
Begin MSComDlg.CommonDialog cdlSave
Left = 2460
Top = 3720
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
DialogTitle = "请选择要另寸的文件名"
Filter = "位图文件(*.BMP)|*.BMP"
End
Begin ActiveToolBars.SSActiveToolBars barIB
Left = 3060
Top = 3720
_ExtentX = 741
_ExtentY = 741
_Version = 131082
MenuAnimations = 3
ToolBarsCount = 1
ToolsCount = 17
Tools = "ImageBrowser.ctx":0000
ToolBars = "ImageBrowser.ctx":2086
End
Begin VB.PictureBox picContainer
Height = 3195
Left = 120
ScaleHeight = 3135
ScaleWidth = 5415
TabIndex = 0
TabStop = 0 'False
Top = 120
Width = 5475
Begin VB.CommandButton cmdStop
Caption = "停止加载"
Height = 375
Left = 120
MouseIcon = "ImageBrowser.ctx":20F8
MousePointer = 99 'Custom
TabIndex = 4
TabStop = 0 'False
Top = 120
Visible = 0 'False
Width = 1155
End
Begin VB.VScrollBar vsc
Height = 3135
Left = 5160
TabIndex = 1
TabStop = 0 'False
Top = 0
Width = 255
End
Begin VB.Image imgSave
Height = 240
Index = 0
Left = 1635
Picture = "ImageBrowser.ctx":2402
Top = 120
Visible = 0 'False
Width = 240
End
Begin VB.Image imgSound
Height = 240
Index = 0
Left = 1650
Picture = "ImageBrowser.ctx":254C
Top = 390
Visible = 0 'False
Width = 240
End
Begin VB.Image imgPrint
Height = 240
Index = 0
Left = 1620
Picture = "ImageBrowser.ctx":2696
Top = 675
Visible = 0 'False
Width = 240
End
Begin VB.Image picImage
Height = 1035
Index = 0
Left = 120
Stretch = -1 'True
Top = 120
Visible = 0 'False
Width = 1455
End
Begin VB.Label lblFileName
Alignment = 2 'Center
Caption = "*"
ForeColor = &H8000000D&
Height = 195
Index = 0
Left = 120
TabIndex = 2
Top = 1260
Visible = 0 'False
Width = 1395
End
End
Begin VB.Label lblInfo
BackColor = &H8000000A&
Height = 195
Left = 120
TabIndex = 3
Top = 3420
Width = 5415
End
End
Attribute VB_Name = "ImageBrowserControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public ImageFiles As New ImageFiles
Private PicOnSameScreen As Integer '一个屏幕可以显示的图片数目
Private PicAllScreen As Integer '一个屏幕实际要显示的图片数目
Public ScreenImageBase As Long '当前屏幕显示的图像序号基数
Private x As Integer
Private y As Integer
Private iMax As Integer
Private Const m_PicLeftMargin = 30
Private Const m_PicTopMargin = 30
Public ThumbWidth As Single '略图的宽度
Public ThumbHeight As Single '略图的高度
'Public SelectedFileName As String '所选择的文件名
Private m_ShowInfo As Boolean '是否显示信息框
Private m_ImageBorder As Boolean '图像是否有边框
Private m_AllowDelete As Boolean '是否允许清除图像
Private m_ShowAttachInfo As Boolean '是否允许显示附加的信息
Private m_AutoEdit As Boolean '双击自动编辑
Public SelectedItems As New Collection '选择图片的索引集合
Public StopLoad As Boolean '是否停止加载图象文件
Public TagString As String '附加的信息，用于单幅图片的打印等
'API声明
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
'事件
Public Event ActivateImage(ImageFile As ImageFile)
Public Event SingleImageSelected(ImageFile As ImageFile)
Public Event BeforePrintSingleImage() '单幅图片被打印前，传递一些信息
Public Event SelectChanged() '被选中的文件发生变化
Public Event message(strMsg As String)
Public Event ActionComplete() '执行某操作结束发生的事件
Public Function PrintSingleImage() As Boolean
'---------------
'打印单幅图片
'---------------
'如果选择的图片数目不是1，则退出过程
If Me.SelectedImageFiles.Count <> 1 Then Exit Function
Dim strFile As String
Dim strHTML As String
Dim strTemp As String
Dim strTempFile As String
Dim cTR As New TextReplace
Dim tst As TextStream
Dim cTRTemp As New TextReplace
Dim i As Integer
'先触发事件，得到打印的信息
RaiseEvent BeforePrintSingleImage
'加载模版文件
strFile = App.Path & "\REPORT\TEMPLATE\SINGLEIMAGEPRINT.HTM"
strTempFile = App.Path & "\REPORT\SINGLEIMAGEPRINT.HTM"
strHTML = FSO.OpenTextFile(strFile).ReadAll
With cTR
.Text = strHTML
.Replace "PICTURE", "<img width=""288"" height=""252"" src=""FILE:///" & Me.ImageFiles(Me.SelectedItems(1)).FileFullName & """> "
.Replace "\", "/"
.Replace "INFO", Me.TagString
End With
Set tst = FSO.CreateTextFile(strTempFile)
tst.Write cTR.Text
With frmReportPreview
.FileName = strTempFile
.Show vbModal
End With
End Function
Public Function PrintImage(Optional PrintAll As Boolean = True) As Boolean
'-----------------
'打印图象
'-----------------
Dim strFile As String
Dim strHTML As String
Dim strTemp As String
Dim strTempFile As String
Dim cTR As New TextReplace
Dim tst As TextStream
Dim cTRTemp As New TextReplace
Dim i As Integer
'加载模版文件
strFile = App.Path & "\REPORT\TEMPLATE\IMAGEPRINT.HTM"
strTempFile = App.Path & "\REPORT\IMAGEPRINT.HTM"
strHTML = FSO.OpenTextFile(strFile).ReadAll
With cTR
.Text = strHTML
.Replace "DAY", Date
strTemp = vbNullString
If PrintAll Then
.Replace "IMAGECOUNT", Me.ImageFiles.Count
For i = 1 To Me.ImageFiles.Count
If IniUS.GetString("Print", "OnlyPrintImage") = "1" Then
strTemp = strTemp & "<img width=" & "" & IniUS.GetString("Print", "ReportImageL") & "" & "height=" & "" & IniUS.GetString("Print", "ReportImageW") & "" & " src=""FILE:///" & Me.ImageFiles(i).FileFullName & """> "
If i Mod Val(IniUS.GetString("Print", "LinePrintNumber")) = 0 Then
strTemp = strTemp & "<br>"
End If
Else
strTemp = strTemp & "<img src=""FILE:///" & Me.ImageFiles(i).FileFullName & """> "
End If
Next i
Else
.Replace "IMAGECOUNT", Me.SelectedItems.Count
For i = 1 To Me.SelectedItems.Count
If IniUS.GetString("Print", "OnlyPrintImage") = "1" Then
strTemp = strTemp & "<img width=" & "" & IniUS.GetString("Print", "ReportImageL") & "" & "height=" & "" & IniUS.GetString("Print", "ReportImageW") & "" & " src=""FILE:///" & Me.ImageFiles(Me.SelectedItems(i)).FileFullName & """> "
If i Mod Val(IniUS.GetString("Print", "LinePrintNumber")) = 0 Then
strTemp = strTemp & "<br>"
End If
Else
strTemp = strTemp & "<img src=""FILE:///" & Me.ImageFiles(Me.SelectedItems(i)).FileFullName & """> "
End If
Next i
End If
' If PrintAll Then
' .Replace "IMAGECOUNT", Me.ImageFiles.Count
' For i = 1 To Me.ImageFiles.Count
' 'strTemp = strTemp & "<img width=""240"" height=""180"" src=""FILE:///" & Me.ImageFiles(i).FileFullName & """> "
' strTemp = strTemp & "<img src=""FILE:///" & Me.ImageFiles(i).FileFullName & """> "
' 'If i Mod 3 = 0 Then
' ' strTemp = strTemp & "<br><br>"
' 'End If
' Next i
' Else
' .Replace "IMAGECOUNT", Me.SelectedItems.Count
' For i = 1 To Me.SelectedItems.Count
' 'strTemp = strTemp & "<img width=""240"" height=""180"" src=""FILE:///" & Me.ImageFiles(Me.SelectedItems(i)).FileFullName & """> "
' strTemp = strTemp & "<img src=""FILE:///" & Me.ImageFiles(Me.SelectedItems(i)).FileFullName & """> "
' 'If i Mod 3 = 0 Then
' ' strTemp = strTemp & "<br><br>"
' 'End If
' Next i
' End If
.Replace "IMAGELIST", strTemp
.Replace "\", "/"
End With
Set tst = FSO.CreateTextFile(strTempFile)
tst.Write cTR.Text
With frmReportPreview
.FileName = strTempFile
.Show vbModal
End With
'释放对象
tst.Close
Set tst = Nothing
Set cTR = Nothing
End Function
Public Property Get SelectedImageFiles() As ImageFiles
'-------------------------
'根据选择的图象序号列表，
'返回对应的文件对象集合
'-------------------------
Dim NewIFs As New ImageFiles
Dim i As Integer
For i = 1 To SelectedItems.Count
NewIFs.Insert Me.ImageFiles(SelectedItems(i))
Next i
Set SelectedImageFiles = NewIFs
'释放对象
Set NewIFs = Nothing
End Property
Public Sub ShowImage()
'-----------------------------
'显示可见区域内的图象
'-----------------------------
On Error Resume Next
Dim i As Integer, Index As Integer
Dim iX As Integer, iY As Integer
Dim iWidth As Integer, iHeight As Integer
Dim W_H_Rate As Single
iMax = IIf((ImageFiles.Count - ScreenImageBase) > PicAllScreen, PicAllScreen, ImageFiles.Count - ScreenImageBase)
Screen.MousePointer = vbHourglass
LockWindowUpdate picContainer.hwnd
'先卸载全部对象
For i = picImage.Count - 1 To 1 Step -1
picImage(i).Visible = False
lblFileName(i).Visible = False
Unload picImage(i)
Unload lblFileName(i)
'如果显示附加信息,,则也要清除这些信息的图表
If ShowAttachInfo Then
imgSave(i).Visible = False
imgSound(i).Visible = False
imgPrint(i).Visible = False
Unload imgSave(i)
Unload imgSound(i)
Unload imgPrint(i)
End If
Next i
'设置是否允许滚动条
If PicOnSameScreen < ImageFiles.Count Then
vsc.Enabled = True
vsc.Min = 0
vsc.Max = ImageFiles.Count / x
vsc.SmallChange = 1
vsc.LargeChange = y
Else
vsc.Enabled = False
End If
'DoEvents
'加载图像
For i = 1 To iMax
Index = i + ScreenImageBase
Load picImage(i)
Load lblFileName(i)
With picImage(i)
iX = (i - 1) Mod x
iY = (i - 1) \ x
.Move UnitWidth * iX + m_PicLeftMargin, UnitHeight * iY + m_PicTopMargin
.ToolTipText = ImageFiles(Index).FileFullName
End With
With lblFileName(i)
.Move picImage(i).Left, picImage(i).Top + ThumbHeight + 30
.Caption = ImageFiles(Index).FileName
'设置缩排过长的文字
Dim strTemp As String
strTemp = .Caption
If picContainer.TextWidth(strTemp) > lblFileName(i).width Then
Do While picContainer.TextWidth(strTemp & "...") > lblFileName(i).width
strTemp = Left(strTemp, Len(strTemp) - 1)
Loop
.Caption = strTemp & "..."
End If
'设置标题文字及被选择情况
.ToolTipText = ImageFiles(Index).FileFullName
If InCollection(Me.SelectedItems, Index) > 0 Then
lblFileName(i).BackColor = &H800000
lblFileName(i).ForeColor = vbWhite
End If
.Visible = True
End With
With picImage(i)
.Picture = LoadPicture(ImageFiles(i + ScreenImageBase).FileFullName)
iWidth = .Picture.width / 26.46 * 15
iHeight = .Picture.height / 26.46 * 15
If iWidth + iHeight > 0 Then '作这个判断的目的是，如果LoadPicture语句失败，则宽度和高度为0，那样会使控件的定位不准
If iWidth < ThumbWidth And iHeight < ThumbHeight Then
.Stretch = False
.Move .Left + (picImage(0).width - iWidth) / 2, .Top + (picImage(0).height - iHeight) / 2
Else
W_H_Rate = iWidth / iHeight
If W_H_Rate > ThumbWidth / ThumbHeight Then
.height = ThumbWidth / W_H_Rate
Else
.width = ThumbHeight * W_H_Rate
End If
.Move .Left + (ThumbWidth - .width) / 2, .Top + (ThumbHeight - .height) / 2
End If
End If
.Visible = True
End With
'如果显示附加信息
If ShowAttachInfo Then
Load imgSave(i)
Load imgSound(i)
Load imgPrint(i)
imgSave(i).Visible = ImageFiles(Index).TagSave
imgSound(i).Visible = ImageFiles(Index).TagSound
imgPrint(i).Visible = ImageFiles(Index).TagPrint
imgSave(i).Move picImage(i).Left + picImage(i).width + 30, picImage(i).Top
imgSound(i).Move picImage(i).Left + picImage(i).width + 30, picImage(i).Top + 270
imgPrint(i).Move picImage(i).Left + picImage(i).width + 30, picImage(i).Top + 540
End If
Next i
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -