frmpicviewer.frm

Family Tree This a geneology program for entering your family tree. It s a complete working app but

'shift key pressed.
'A separate hotspot image is used.
    If Shift = 1 Then
        Y1 = Y
        X1 = X
        imgHotSpot.Left = X1
        imgHotSpot.Top = Y1
        imgHotSpot.Width = 0
        imgHotSpot.Height = 0
        imgHotSpot.Visible = True
    End If
End Sub

Private Sub picViewer_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'This is used to draw the hotspot image (if shift is pressed) or
'to show the tooltip text when pointing at people
Dim i As Integer
Dim bfound As Boolean
Dim sngX As Single
Dim sngY As Single

'Set two variables which represent the left and top of the actual image
    sngX = (picViewer.Width - (msngWidth * msngFactor)) / 2
    sngY = (picViewer.Height - (msngHeight * msngFactor)) / 2

    If Shift = 1 Then
        'Stretch out the hotspot image
        If Button = 1 Then
            If X > X1 Then imgHotSpot.Width = X - X1
            If Y > Y1 Then imgHotSpot.Height = Y - Y1
        End If
    Else
        'set the tooltip text for the appropriate hotspot.
        With CPhoto
            For i = 1 To .Count
                If X >= (.Item(i).X1 * msngFactor) + sngX - (HScroll.Value * 15) And X <= (.Item(i).X2 * msngFactor) + sngX - (HScroll.Value * 15) And Y >= (.Item(i).Y1 * msngFactor) + sngY - (VScroll.Value * 15) And Y <= (.Item(i).Y2 * msngFactor) + sngY - (VScroll.Value * 15) Then
                    picViewer.ToolTipText = .Item(i).Note
                    bfound = True
                    Exit For
                End If
            Next i
        End With
        If Not bfound Then
            picViewer.ToolTipText = ""
        End If
    End If
    
End Sub

Private Sub picViewer_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'If the shift key is pressed this adds the hotspot to the collection
Dim sName As String
Dim lngIndId As Long
Dim sngX As Single
Dim sngY As Single
Dim i As Integer

'Set two variables which represent the left and top of the actual image
    sngX = (picViewer.Width - (msngWidth * msngFactor)) / 2
    sngY = (picViewer.Height - (msngHeight * msngFactor)) / 2

    If Shift = 1 Then
        imgHotSpot.Visible = False
        X2 = X
        Y2 = Y
        'Invoke the form to get the name caption
        sName = frmGetCaption.invoke(lngIndId)
        If sName <> "" Then
            'Add the new hotspot to the collection
            Call CPhoto.Add(lngIndId, (X1 - sngX) / msngFactor, (Y1 - sngY) / msngFactor, (X2 - sngX) / msngFactor, (Y2 - sngY) / msngFactor, sName)
            If Toolbar1.Buttons("Frames").Value = vbChecked Then
                If imgFrame.Count > 0 Then
                    i = imgFrame.Count
                    Load imgFrame(i)
                Else
                    i = 0
                End If
                imgFrame(i).Left = (CPhoto(i + 1).X1 * msngFactor) + sngX
                imgFrame(i).Top = (CPhoto(i + 1).Y1 * msngFactor) + sngY
                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
            End If
            Toolbar1.Buttons("Save").Enabled = True
        End If
    End If
End Sub

Private Sub Timer1_Timer()
'This does all the work of drawing the image.
'It cant be done before the form is made visible - hence this technique
    Timer1.Interval = Val(GetOption(3)) * 1000

'Paint the picture on the picturebox
    If Toolbar1.Buttons("SlideShow").Value = tbrPressed Then
        Timer1.Enabled = True
        NextPicture
    Else
        Timer1.Enabled = False
        DrawPicture
    End If
    
End Sub

Private Function LoadHotSpots() As Boolean
'This loads the hotspots for the image from the database into the collection
Dim RS As ADODB.Recordset
Dim SQL As String
Dim sErr As String

    On Error GoTo ErrSub:
    
    Set CPhoto = Nothing
    Set CPhoto = New colPhotoNames

    SQL = "Select * FROM " & gtcHOTSPOTS & " WHERE " & _
            gccHSPIMGID & " = " & mlngImgId

    Set RS = New ADODB.Recordset
    
    RS.Open SQL, gApp.cn, adOpenForwardOnly, adLockReadOnly
    
    Do While Not RS.EOF
        Call CPhoto.Add(RS(gccHSPINDID), RS(gccHSPX1), RS(gccHSPY1), RS(gccHSPX2), RS(gccHSPY2), RS(gccHSPNOTE))
        RS.MoveNext
    Loop
    

Exit Function
ErrSub:
    sErr = Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
            "In Module " & Me.Name & vbCrLf & _
            "In Sub cmdSave_Click"
            
    Call Showerror(sErr, 0)

End Function

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case UCase(Button.Key)
        Case "EXIT"
            If Toolbar1.Buttons("Save").Enabled Then
                If MsgBox("You have changed/added some captions - save these changes?", vbYesNo Or vbQuestion, Me.Caption) = vbYes Then
                    SaveData
                Else
                    Toolbar1.Buttons("Save").Enabled = False
                End If
            End If
            Set CPhoto = Nothing
            Unload Me
        Case "FRAMES"
            Call ShowHideFrames(Toolbar1.Buttons("Frames").Value)
        Case "SAVE"
            SaveData
        Case "PRINT"
            PrintPicture
        Case "ZOOMIN"
            Call ZoomIn
        Case "ZOOMOUT"
            Call ZoomOut
        Case "SLIDESHOW"
            mbPrev = False
            If Toolbar1.Buttons("SlideShow").Value = tbrPressed Then
                Toolbar1.Buttons("SlideShow").Caption = "End Show"
                mbEnd = False
                Call SlideShow
            Else
                Toolbar1.Buttons("SlideShow").Caption = "Slide Show"
                mbEnd = True
            End If
        Case "PREV"
            mbPrev = True
            NextPicture
        Case "NEXT"
            mbPrev = False
            NextPicture
    End Select
End Sub

Private Function SaveData() As Boolean
'Save the data from the collection back to the database
Dim RS As ADODB.Recordset
Dim SQL As String
Dim sErr As String
Dim i As Integer

    On Error GoTo ErrSub

'Firstly delete the hotspot info
    SQL = "Delete FROM " & gtcHOTSPOTS & " WHERE " & _
            gccHSPIMGID & " = " & mlngImgId
    
    gApp.cn.Execute SQL

'Now re-insert it from the collection
    With CPhoto
        For i = 1 To CPhoto.Count
            SQL = "Insert into " & gtcHOTSPOTS & " ( " & _
                gccHSPIMGID & ", " & _
                gccHSPSEQ & ", " & _
                gccHSPINDID & ", " & _
                gccHSPX1 & ", " & _
                gccHSPX2 & ", " & _
                gccHSPY1 & ", " & _
                gccHSPY2 & ", " & _
                gccHSPNOTE & ") VALUES (" & _
                mlngImgId & ", " & _
                i & ", " & _
                .Item(i).IndId & ", " & _
                .Item(i).X1 & ", " & _
                .Item(i).X2 & ", " & _
                .Item(i).Y1 & ", " & _
                .Item(i).Y2 & ", '" & _
                .Item(i).Note & "')"
    
            gApp.cn.Execute SQL
            
            If .Item(i).IndId <> 0 Then
                SQL = "Select * from " & gtcIMAGELINK & " WHERE " & _
                    gccIMLIMGID & " = " & mlngImgId & " AND " & _
                    gccIMLINDID & " = " & .Item(i).IndId
                
                Set RS = New ADODB.Recordset
                
                RS.Open SQL, gApp.cn, adOpenKeyset, adLockOptimistic
                
                If RS.BOF And RS.EOF Then
                    RS.AddNew
                    RS(gccIMLIMGID) = mlngImgId
                    RS(gccIMLINDID) = .Item(i).IndId
                    RS.Update
                    RS.Close
                End If
            End If
        Next i
    End With
    Toolbar1.Buttons("Save").Enabled = False
    
Exit Function
ErrSub:
    sErr = Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
            "In Module " & Me.Name & vbCrLf & _
            "In Sub SaveData"
            
    Call Showerror(sErr, 0)

End Function

Private Sub VScroll_Change()
'Hide all the frames
    Call ShowHideFrames(False)
'Blank out the picture
    picViewer.Picture = LoadPicture("")
'Let the timer take care of redrawing the picture
    Timer1.Enabled = True
End Sub

Private Function PrintPicture() As Boolean
'Print the picture using standard windows print technique.
'FIXIT - Need to add the captions overlay on a separate page or
'further down the same page if both will fit.
Dim sngX As Single
Dim sngY As Single
Dim X As Printer
Dim sErr As String

    On Error GoTo ErrSub
    
    comDlg.ShowPrinter

    Printer.Orientation = comDlg.Orientation

    sngX = (Printer.Width - (msngWidth * msngFactor)) / 2
    sngY = (Printer.Height - (msngHeight * msngFactor)) / 2
    
    Printer.PaintPicture objPic, sngX, sngY, msngWidth * msngFactor, msngHeight * msngFactor
    Printer.EndDoc

Exit Function
ErrSub:
    sErr = Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
            "In Module " & Me.Name & vbCrLf & _
            "In Function PrintPicture"
            
    Call Showerror(sErr, 0)

End Function

Private Function ShowPicture(lngImgId As Long, sPath As String, sCaption As String, sName As String) As Boolean
Dim sErr As String

    On Error GoTo ErrSub

    'make the image id accessible by all other functions
    mlngImgId = lngImgId
    Me.Caption = sName

    'load the picture
    Set objPic = Nothing
    Set objPic = LoadPicture(sPath)
    
    'Don't know why I used 26.4577 but it scales it correctly
    msngWidth = (objPic.Width / 26.4577) * 15   'This is now width in twips
    msngHeight = (objPic.Height / 26.4577) * 15 'This is now height in twips
        
    msngFactor = 1
    
    'Now see if the picture will fit in the picturebox
    If msngWidth > picViewer.Width Then
        msngFactor = picViewer.Width / msngWidth
    End If

    If msngHeight * msngFactor > picViewer.Height Then
        msngFactor = picViewer.Height / msngHeight
    End If
    
    'Set the zoom percentage
    txtZoom = Format(Int(msngFactor * 100), "###") & " %"
        
    lblCaption.Caption = sCaption
    picViewer.Picture = LoadPicture()
    LoadHotSpots
    
Exit Function
ErrSub:
    sErr = Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
            "In Module " & Me.Name & vbCrLf & _
            "In Function PrintPicture"
            
    Call Showerror(sErr, 0)

End Function


Private Function SlideShow() As Boolean
Dim SQL As String
Dim sErr As String

    On Error GoTo ErrSub
    
    If mRS Is Nothing Then
        Set mRS = New ADODB.Recordset
    End If
    
    If mRS.State = 0 Then
        SQL = "Select * from " & gtcIMAGES & " ORDER BY " & _
                gccIMGDATEDATE
                
        
        mRS.Open SQL, gApp.cn, adOpenDynamic, adLockOptimistic
    End If
    
    Toolbar1.Buttons("Next").Enabled = True
    Toolbar1.Buttons("Prev").Enabled = True
    
    If Not mRS.EOF And Not mRS.BOF Then
        Call ShowPicture(mRS(gccIMGID), App.Path & "\" & mRS(gccIMGNAME), mRS(gccIMGCAPTION), mRS(gccIMGCAPTION))
        DoEvents
        DrawPicture
        Timer1.Interval = Val(GetOption(3)) * 1000
        Timer1.Enabled = True
    End If
    
Exit Function
ErrSub:
    sErr = Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
            "In Module " & Me.Name & vbCrLf & _
            "In Function PrintPicture"
            
    Call Showerror(sErr, 0)

End Function

Private Function NextPicture() As Boolean
    If mbPrev Then
        If Not mRS.BOF Then
            mRS.MovePrevious
            If Not mRS.BOF Then
                Call ShowPicture(mRS(gccIMGID), App.Path & "\" & mRS(gccIMGNAME), mRS(gccIMGCAPTION), mRS(gccIMGCAPTION))
                DoEvents
            Else
                mRS.Close
                Toolbar1.Buttons("SlideShow").Value = tbrUnpressed
                Toolbar1.Buttons("Prev").Enabled = False
                Toolbar1.Buttons("Next").Enabled = False
            End If
        Else
            mRS.Close
            Toolbar1.Buttons("SlideShow").Value = tbrUnpressed
            Toolbar1.Buttons("Prev").Enabled = False
            Toolbar1.Buttons("Next").Enabled = False
        End If
    Else
        If Not mRS.EOF Then
            mRS.MoveNext
            If Not mRS.EOF Then
                Call ShowPicture(mRS(gccIMGID), App.Path & "\" & mRS(gccIMGNAME), mRS(gccIMGCAPTION), mRS(gccIMGCAPTION))
                DoEvents
            Else
                mRS.Close
                Toolbar1.Buttons("SlideShow").Value = tbrUnpressed
                Toolbar1.Buttons("Prev").Enabled = False
                Toolbar1.Buttons("Next").Enabled = False
            End If
        Else
            mRS.Close
            Toolbar1.Buttons("SlideShow").Value = tbrUnpressed
            Toolbar1.Buttons("Prev").Enabled = False
            Toolbar1.Buttons("Next").Enabled = False
        End If
    End If

    DrawPicture

End Function

Private Function DrawPicture()
Dim sngX As Single
Dim sngY As Single
Static sngHFactor As Single
Static sngVFactor As Single

'Set two variables which represent the left and top of the actual image
    sngX = (picViewer.Width - (msngWidth * msngFactor)) / 2
    sngY = (picViewer.Height - (msngHeight * msngFactor)) / 2
    
'Make the Horizontal and Vertical scrollbars visible if appropriate
    If sngX < 1 Then
        HScroll.Visible = True
        HScroll.Max = ((msngWidth * msngFactor) - picViewer.Width) / 30 'Make it pixels
        HScroll.Min = HScroll.Max * -1
    Else
        HScroll.Visible = False
        HScroll.Value = 0
        HScroll.Max = 0
    End If
    If sngY < 1 Then
        VScroll.Visible = True
        VScroll.Max = ((msngHeight * msngFactor) - picViewer.Height) / 30  'Make it pixels
        VScroll.Min = VScroll.Max * -1
    Else
        VScroll.Visible = False
        VScroll.Value = 0
        VScroll.Max = 0
    End If
        
    picViewer.PaintPicture objPic, sngX - (HScroll.Value * 15), sngY - (VScroll.Value * 15), msngWidth * msngFactor, msngHeight * msngFactor
    DoEvents
'Switch the timer off
'Show or hide the frames depending on the state of the toolbar frames button
    Call ShowHideFrames(Toolbar1.Buttons("Frames").Value)
    
End Function