📄 frmpicviewer.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmPicViewer
AutoRedraw = -1 'True
BorderStyle = 1 'Fixed Single
Caption = "Form1"
ClientHeight = 8625
ClientLeft = 45
ClientTop = 330
ClientWidth = 11910
Icon = "frmPicViewer.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 8625
ScaleWidth = 11910
StartUpPosition = 1 'CenterOwner
Begin MSComDlg.CommonDialog comDlg
Left = 60
Top = 4470
_ExtentX = 847
_ExtentY = 847
_Version = 393216
DialogTitle = "Select Printer"
End
Begin VB.HScrollBar HScroll
Height = 255
LargeChange = 150
Left = 240
SmallChange = 30
TabIndex = 4
TabStop = 0 'False
Top = 8370
Visible = 0 'False
Width = 11385
End
Begin VB.VScrollBar VScroll
Height = 7065
LargeChange = 150
Left = 11640
SmallChange = 30
TabIndex = 3
TabStop = 0 'False
Top = 1290
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox picViewer
AutoRedraw = -1 'True
Height = 7065
Left = 240
ScaleHeight = 7005
ScaleWidth = 11325
TabIndex = 2
Top = 1290
Width = 11385
Begin VB.Image imgHotSpot
Appearance = 0 'Flat
BorderStyle = 1 'Fixed Single
Height = 945
Left = 1530
Top = 390
Visible = 0 'False
Width = 825
End
Begin VB.Image imgFrame
Appearance = 0 'Flat
BorderStyle = 1 'Fixed Single
Height = 645
Index = 0
Left = 0
Top = 0
Visible = 0 'False
Width = 615
End
End
Begin MSComctlLib.ImageList ImageList1
Left = 30
Top = 6570
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 9
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":058A
Key = "frames"
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":0E64
Key = "Print"
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":13A6
Key = "Save"
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":18E8
Key = "Exit"
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":21C2
Key = "zoomin"
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":24DC
Key = "zoomout"
EndProperty
BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":27F6
Key = "prev"
EndProperty
BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":2C48
Key = "next"
EndProperty
BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmPicViewer.frx":309A
Key = "slideshow"
EndProperty
EndProperty
End
Begin MSComctlLib.Toolbar Toolbar1
Align = 1 'Align Top
Height = 600
Left = 0
TabIndex = 1
Top = 0
Width = 11910
_ExtentX = 21008
_ExtentY = 1058
ButtonWidth = 1879
ButtonHeight = 953
ImageList = "ImageList1"
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 9
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "Exit"
Key = "Exit"
Object.ToolTipText = "Show Frames"
ImageKey = "Exit"
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "Show Frames"
Key = "Frames"
ImageKey = "frames"
Style = 1
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Enabled = 0 'False
Caption = "Save"
Key = "Save"
ImageKey = "Save"
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "Print"
Key = "Print"
ImageKey = "Print"
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "Zoom In"
Key = "ZoomIn"
ImageKey = "zoomin"
EndProperty
BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "Zoom Out"
Key = "ZoomOut"
ImageKey = "zoomout"
EndProperty
BeginProperty Button7 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "Slide Show"
Key = "SlideShow"
ImageKey = "slideshow"
Style = 1
EndProperty
BeginProperty Button8 {66833FEA-8583-11D1-B16A-00C0F0283628}
Enabled = 0 'False
Caption = "Prev Slide"
Key = "Prev"
ImageKey = "prev"
EndProperty
BeginProperty Button9 {66833FEA-8583-11D1-B16A-00C0F0283628}
Enabled = 0 'False
Caption = "Next Slide"
Key = "Next"
ImageKey = "next"
EndProperty
EndProperty
Begin VB.TextBox txtZoom
Alignment = 2 'Center
Height = 315
Left = 9630
TabIndex = 5
Text = "100%"
Top = 150
Width = 975
End
End
Begin VB.Timer Timer1
Interval = 1
Left = 8490
Top = 0
End
Begin VB.Label lblCaption
Alignment = 2 'Center
Caption = "Caption"
BeginProperty Font
Name = "Baskerville Old Face"
Size = 14.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 585
Left = 0
TabIndex = 0
Top = 630
Width = 11865
End
Begin VB.Menu mnuPopUp
Caption = "Popup Menu"
Visible = 0 'False
Begin VB.Menu mnuPopInfo
Caption = "Show Information"
End
Begin VB.Menu mnuPopRemove
Caption = "Remove Frame"
End
Begin VB.Menu mnuPopSep1
Caption = "-"
End
Begin VB.Menu mnuPopCancel
Caption = "Cancel"
End
End
End
Attribute VB_Name = "frmPicViewer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private X, Y As Single
Private msngWidth, msngHeight As Single
Private msngFactor As Single
Private objPic As IPicture
Private X1 As Long
Private X2 As Long
Private Y1 As Long
Private Y2 As Long
Private miIndex As Integer
Private mbEnd As Boolean
Private mbPrev As Boolean
Private mRS As ADODB.Recordset
Private CPhoto As colPhotoNames
Private mlngImgId As Long 'Need this to save the captions
Public Function invoke(lngImgId As Long, sPath As String, sCaption As String, sName As String)
'Entry point for the form.
Dim Factor As Single
Call ShowPicture(lngImgId, sPath, sCaption, sName)
Me.Show vbModal
End Function
Private Sub ShowHideFrames(bShow As Boolean)
'This function reads through the collection and displays an image with a fixed border
'for each element in the array
Dim i As Integer
Dim sngX As Single
Dim sngY As Single
On Error GoTo ErrSub
'Because the picture is always centred in the picturebox we need to get the
'actual top and left X values of the actual picture.
sngX = (picViewer.Width - (msngWidth * msngFactor)) / 2
sngY = (picViewer.Height - (msngHeight * msngFactor)) / 2
'unload all images and make index 0 invisible
imgFrame(0).Visible = False
On Error Resume Next
For i = 1 To imgFrame.Count - 1
Unload imgFrame(i)
Next i
On Error GoTo ErrSub
'If the parameter is set to show then reload and redraw all the images for
'each item in the collection
If bShow = True Then
For i = 0 To CPhoto.Count - 1
If i > 0 Then
Load imgFrame(i)
End If
'Left and top are the recorded X and Y positions * the scaling factor
'plus the offset of the picture in the frame and then minus the value
'to where the picture is scrolled (if it is scrolled at all).
imgFrame(i).Left = (CPhoto(i + 1).X1 * msngFactor) + sngX - (HScroll.Value * 15)
imgFrame(i).Top = (CPhoto(i + 1).Y1 * msngFactor) + sngY - (VScroll.Value * 15)
imgFrame(i).Width = (CPhoto(i + 1).X2 - CPhoto(i + 1).X1) * msngFactor
imgFrame(i).Height = (CPhoto(i + 1).Y2 - CPhoto(i + 1).Y1) * msngFactor
imgFrame(i).Visible = True
imgFrame(i).ToolTipText = CPhoto(i + 1).Note
Next i
End If
Exit Sub
ErrSub:
End Sub
Private Sub ZoomIn()
Dim sngZoom As Single
'Hide all the image frames
Call ShowHideFrames(False)
sngZoom = Val(txtZoom)
'Set the appropriate zoom level based on the current setting
If sngZoom <= 5 Then
sngZoom = 10
ElseIf sngZoom <= 10 Then sngZoom = 20
ElseIf sngZoom <= 20 Then sngZoom = 25
ElseIf sngZoom <= 25 Then sngZoom = 50
ElseIf sngZoom <= 50 Then sngZoom = 75
ElseIf sngZoom <= 75 Then sngZoom = 100
ElseIf sngZoom <= 100 Then sngZoom = 125
ElseIf sngZoom <= 125 Then sngZoom = 150
ElseIf sngZoom <= 150 Then sngZoom = 175
ElseIf sngZoom <= 175 Then sngZoom = 200
ElseIf sngZoom <= 200 Then sngZoom = 250
ElseIf sngZoom <= 250 Then sngZoom = 300
ElseIf sngZoom <= 300 Then sngZoom = 350
ElseIf sngZoom <= 350 Then sngZoom = 400
End If
'set the scaling factor to the new zoom level
msngFactor = sngZoom / 100
txtZoom = Format(Int(msngFactor * 100), "###") & " %"
'blank out the picture box
picViewer.Picture = LoadPicture("")
'let the timer take care of drawing the picture
DrawPicture
End Sub
Private Sub ZoomOut()
Dim sngZoom As Single
'Hide all the frames
Call ShowHideFrames(False)
sngZoom = Val(txtZoom)
'Set the appropriate zoom level based on the current setting
If sngZoom >= 400 Then
sngZoom = 350
ElseIf sngZoom >= 350 Then sngZoom = 300
ElseIf sngZoom >= 300 Then sngZoom = 250
ElseIf sngZoom >= 250 Then sngZoom = 200
ElseIf sngZoom >= 200 Then sngZoom = 150
ElseIf sngZoom >= 150 Then sngZoom = 125
ElseIf sngZoom >= 125 Then sngZoom = 100
ElseIf sngZoom >= 100 Then sngZoom = 75
ElseIf sngZoom >= 75 Then sngZoom = 50
ElseIf sngZoom >= 50 Then sngZoom = 25
ElseIf sngZoom >= 25 Then sngZoom = 10
ElseIf sngZoom >= 10 Then sngZoom = 5
End If
'set the scaling factor to the new zoom level
msngFactor = sngZoom / 100
txtZoom = Format(Int(msngFactor * 100), "###") & " %"
'blank out the picture box
picViewer.Picture = LoadPicture("")
'let the timer take care of drawing the picture
DrawPicture
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'Don't allow quitting if the data hasn't been saved - could be more user friendly!
If Toolbar1.Buttons("Save").Enabled Then Cancel = 1
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
mRS.Close
Set mRS = Nothing
End Sub
Private Sub HScroll_Change()
'Hide the frames
Call ShowHideFrames(False)
'Blank out the picture
picViewer.Picture = LoadPicture("")
'Let the time take care of redrawing the picture
Timer1.Enabled = True
End Sub
Private Sub imgFrame_Click(Index As Integer)
'This sub opens up the caption form for adding/changing the caption
'This can only be done if the frames are visible
Dim sName As String
Dim lngId As Long
lngId = CPhoto.Item(Index + 1).IndId
sName = frmGetCaption.invoke(lngId, CPhoto.Item(Index + 1).Note)
If sName <> "" Then
CPhoto.Item(Index + 1).Note = sName
CPhoto.Item(Index + 1).IndId = lngId
Toolbar1.Buttons("Save").Enabled = True
End If
End Sub
Private Sub imgFrame_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'Open up the pop-up menu if right clicking on an image
If Button = vbRightButton Then
miIndex = Index
PopupMenu mnuPopUp
End If
End Sub
Private Sub mnuPopInfo_Click()
imgFrame_Click (miIndex)
End Sub
Private Sub mnuPopRemove_Click()
'Remove a frame.
'Firstly Remove the reference from the collection
CPhoto.Remove (miIndex + 1)
'Redisplay the frames
ShowHideFrames (False)
ShowHideFrames (True)
Toolbar1.Buttons("Save").Enabled = True
End Sub
Private Sub picViewer_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'This is used when drawing new frames on the picturebox. It needs to be done with the
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -