Mastering Visual Basic 6/mastvb6.iso/annotate/annotate.frm

Visual Basic Form | 1998-07-10 | 15.4 KB | 506 lines

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form AnnotationsForm
   Caption         =   "Map Annotation"
   ClientHeight    =   6090
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   8295
   FillStyle       =   0  'Solid
   BeginProperty Font
      Name            =   "Comic Sans MS"
      Size            =   12
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   6090
   ScaleWidth      =   8295
   StartUpPosition =   3  'Windows Default
   Visible         =   0   'False
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   0
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.PictureBox Picture1
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BeginProperty Font
         Name            =   "Comic Sans MS"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      FontTransparent =   0   'False
      ForeColor       =   &H000000C0&
      Height          =   5775
      Left            =   120
      ScaleHeight     =   381
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   533
      TabIndex        =   0
      Top             =   120
      Width           =   8055
      Begin VB.PictureBox Bullet
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H00FFFFFF&
         BorderStyle     =   0  'None
         DrawWidth       =   2
         FillColor       =   &H000000C0&
         BeginProperty Font
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FF0000&
         Height          =   225
         Index           =   0
         Left            =   480
         ScaleHeight     =   15
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   15
         TabIndex        =   1
         Top             =   120
         Visible         =   0   'False
         Width           =   225
      End
   End
   Begin VB.Menu FileMenu
      Caption         =   "File"
      Begin VB.Menu FileNew
         Caption         =   "New"
      End
      Begin VB.Menu FileOpen
         Caption         =   "Open"
      End
      Begin VB.Menu FileSaveAs
         Caption         =   "Save As"
      End
      Begin VB.Menu sep0
         Caption         =   "-"
      End
      Begin VB.Menu FileExit
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu AnnotationsMenu
      Caption         =   "Annotations"
      Begin VB.Menu ColorMenu
         Caption         =   "Color"
         Begin VB.Menu BlueDot
            Caption         =   "Blue"
         End
         Begin VB.Menu RedDot
            Caption         =   "Red"
         End
         Begin VB.Menu GreenDot
            Caption         =   "Green"
         End
         Begin VB.Menu YellowDot
            Caption         =   "Yellow"
         End
         Begin VB.Menu WhiteDot
            Caption         =   "White"
         End
         Begin VB.Menu BlackDot
            Caption         =   "Black"
         End
      End
      Begin VB.Menu ShapeMenu
         Caption         =   "Shape"
         Begin VB.Menu ShapeCircle
            Caption         =   "Circle"
         End
         Begin VB.Menu ShapeDot
            Caption         =   "Dot"
         End
         Begin VB.Menu ShapeBox
            Caption         =   "Box"
         End
         Begin VB.Menu ShapeXBox
            Caption         =   "XBox"
         End
      End
      Begin VB.Menu sep1
         Caption         =   "-"
      End
      Begin VB.Menu DotsComments
         Caption         =   "Comments"
      End
      Begin VB.Menu sep2
         Caption         =   "-"
      End
      Begin VB.Menu DotsDelete
         Caption         =   "Delete"
      End
   End
   Begin VB.Menu ImageMenu
      Caption         =   "Image"
      Begin VB.Menu ImageShow
         Caption         =   "Show"
      End
      Begin VB.Menu ImageHide
         Caption         =   "Hide"
      End
      Begin VB.Menu sep3
         Caption         =   "-"
      End
      Begin VB.Menu ShowNotes
         Caption         =   "Notes"
      End
   End
Attribute VB_Name = "AnnotationsForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim maxMarks As Integer
Dim MAPNAME As String
Dim MARKCOLOR As Long
Dim MARKSHAPE As String
Dim selDotIndex As Integer
Dim Notes(1000) As String
Dim XStart As Single, YStart As Single
Dim Dragging As Boolean
Private Sub BlackDot_Click()
    MARKCOLOR = RGB(0, 0, 0)
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, MARKSHAPE
    End If
    ClearColorChecks
    BlackDot.Checked = True
End Sub
Private Sub BlueDot_Click()
    MARKCOLOR = RGB(0, 0, 255)
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, MARKSHAPE
    End If
    ClearColorChecks
    BlueDot.Checked = True
End Sub
Private Sub Bullet_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        Dragging = True
        XStart = X
        YStart = Y
        Bullet(Index).ZOrder 0
    End If
End Sub
Private Sub Bullet_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not Dragging Or Button <> vbLeftButton Then Exit Sub
    Bullet(Index).Visible = False
    Bullet(Index).Move Bullet(Index).Left + (X - XStart), Bullet(Index).Top + (Y - YStart)
    Bullet(Index).Visible = True
    DrawBullet Index, Bullet(Index).FillColor, Bullet(Index).Tag
End Sub
Private Sub Bullet_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton Then
        selDotIndex = Index
        MARKSHAPE = Bullet(selDotIndex).Tag
        PopupMenu AnnotationsMenu
    ElseIf Button = vbLeftButton Then
        Dragging = False
    End If
End Sub
Private Sub DotsComments_Click()
    If selDotIndex = -1 Then Exit Sub
    CommentsForm.Text1.Text = Notes(selDotIndex)
    CommentsForm.Show vbModal
    Notes(selDotIndex) = CommentsForm!Text1.Text
    Bullet(selDotIndex).ToolTipText = Notes(selDotIndex)
End Sub
Private Sub DotsDelete_Click()
    Unload Bullet(selDotIndex)
    selDotIndex = -1
End Sub
Private Sub FileNew_Click()
StartAgain:
    CommonDialog1.DialogTitle = "Select Map to Annotate"
    CommonDialog1.Filter = "Images|*.BMP;*.GIF;*.JPG"
    CommonDialog1.CancelError = True
    On Error GoTo NoGasMapFile
    CommonDialog1.ShowOpen
On Error GoTo BadBMPFile
    Picture1.Picture = LoadPicture(CommonDialog1.FileName)
    DoEvents
    MAPNAME = CommonDialog1.FileName
    ClearDots
    AnnotationsForm.Palette = Picture1.Picture
    Picture1.Picture = LoadPicture(MAPNAME)
    AnnotationsForm.Width = Picture1.Width + 3 * Picture1.Left
    AnnotationsForm.Height = Picture1.Height + 60 * Screen.TwipsPerPixelY
    AnnotationsForm.Refresh
Exit Sub
NoGasMapFile:
    End
BadBMPFile:
    MsgBox CommonDialog1.FileName & " could not be opened." & vbCrLf & "Please try again with a different file"
    GoTo StartAgain
End Sub
Private Sub FileOpen_Click()
    CommonDialog1.DialogTitle = "Select Map to Annotate"
    CommonDialog1.Filter = "Application Files|*.ANT"
    CommonDialog1.InitDir = App.Path
    CommonDialog1.CancelError = True
On Error GoTo FileOpenError
    CommonDialog1.ShowOpen
    fNum = FreeFile()
    Open CommonDialog1.FileName For Input As #fNum
    Input #fNum, MAPNAME
    On Error GoTo ImageNotFound
    Picture1.Picture = LoadPicture(MAPNAME)
    AnnotationsForm.Palette = Picture1.Picture
    Picture1.Picture = LoadPicture(MAPNAME)
    AnnotationsForm.Width = Picture1.Width + 3 * Picture1.Left
    AnnotationsForm.Height = Picture1.Height + 60 * Screen.TwipsPerPixelY
    AnnotationsForm.Refresh
    ClearDots
    On Error Resume Next
    i = 0
    While Not EOF(fNum)
        i = i + 1
        Load Bullet(i)
        Bullet(i).Visible = True
        Input #fNum, BLeft, BTop, BColor, BShape, BNote
        Bullet(i).Left = BLeft
        Bullet(i).Top = BTop
        DrawBullet (i), (BColor), (BShape)
        Notes(i) = BNote
        Bullet(i).ToolTipText = BNote
    Wend
    maxMarks = i
    Close #fNum
    Exit Sub
FileOpenError:
    Exit Sub
ImageNotFound:
   MsgBox "Image file " & MAPNAME & " not found"
   Exit Sub
End Sub
Private Sub FileSaveAs_Click()
CommonDialog1.DialogTitle = "Select Project File to Open"
CommonDialog1.DefaultExt = "ANT"
CommonDialog1.Filter = "Application Files|*.ANT"
CommonDialog1.CancelError = True
On Error GoTo FileSaveError
CommonDialog1.ShowSave
fNumMap = FreeFile()
Open CommonDialog1.FileName For Output As #fNumMap
    Print #fNumMap, MAPNAME
    On Error Resume Next
    For i = 1 To maxMarks
        thisDot = thisDot + 1
        vtest = Bullet(i).Visible
        If Err.Number = 0 Then
            Print #fNumMap, Bullet(i).Left, Bullet(i).Top, Bullet(i).FillColor, Bullet(i).Tag
            Print #fNumMap, Chr(34) & Notes(i) & Chr(34)
        End If
        Err.Clear
    Next
    Close #fNumMap
    Exit Sub
FileSaveError:
    MsgBox "Error in saving annotation map!"
    On Error Resume Next
    Close #fNumMap
End Sub
Private Sub Form_Load()
    Me.Show
    maxMarks = 0
    MARKCOLOR = RGB(255, 0, 0)
    MARKSHAPE = "BOX"
    msg = "Select New or Open from the File menu"
    Picture1.Print msg
End Sub
Private Sub GreenDot_Click()
    MARKCOLOR = RGB(0, 255, 0)
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, MARKSHAPE
    End If
    ClearColorChecks
    GreenDot.Checked = True
End Sub
Private Sub ImageHide_Click()
    Picture1.Picture = LoadPicture()
    RedrawDots
End Sub
Private Sub ImageShow_Click()
    Picture1.Picture = LoadPicture(MAPNAME)
    RedrawDots
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If MAPNAME = "" Then Exit Sub
    If Button = 2 Then
        maxMarks = maxMarks + 1
        Load Bullet(maxMarks)
        Bullet(maxMarks).Move X - Bullet(maxMarks).ScaleWidth / 2, Y - Bullet(maxMarks).ScaleHeight / 2
        Bullet(maxMarks).Visible = True
        Bullet(maxMarks).ToolTipText = ""
        Bullet(maxMarks).Tag = MARKSHAPE
        DrawBullet maxMarks, MARKCOLOR, MARKSHAPE
    End If
End Sub
Function DrawBullet(BulletIndex As Integer, FRCOLOR As Long, FRSHAPE As String)
    Bullet(BulletIndex).PaintPicture Picture1.Image, _
       0, 0, Bullet(BulletIndex).ScaleWidth, Bullet(BulletIndex).ScaleHeight, _
       Bullet(BulletIndex).Left, Bullet(BulletIndex).Top, _
       Bullet(BulletIndex).ScaleWidth, Bullet(BulletIndex).ScaleHeight, _
13369376
    Bullet(BulletIndex).FillColor = FRCOLOR
    Bullet(BulletIndex).ForeColor = FRCOLOR
    Bullet(BulletIndex).Tag = FRSHAPE
    If FRSHAPE = "CIRCLE" Then
        X = Bullet(BulletIndex).ScaleWidth / 2
        Y = Bullet(BulletIndex).ScaleHeight / 2
        Bullet(BulletIndex).Circle (X, Y), X * 0.9
    ElseIf FRSHAPE = "DOT" Then
        X = Bullet(BulletIndex).ScaleWidth / 2
        Y = Bullet(BulletIndex).ScaleHeight / 2
        Bullet(BulletIndex).FillStyle = 0
        Bullet(BulletIndex).Circle (X, Y), X * 0.9
        Bullet(BulletIndex).FillStyle = 1
    ElseIf FRSHAPE = "BOX" Or FRSHAPE = "XBOX" Then
        X = Bullet(BulletIndex).ScaleWidth
        Y = Bullet(BulletIndex).ScaleHeight
        Bullet(BulletIndex).DrawWidth = 2
        Bullet(BulletIndex).Line (2, 2)-(X - 2, Y - 2), , B
        If FRSHAPE = "XBOX" Then
            Bullet(BulletIndex).Line (2, 2)-(X - 2, Y - 2)
            Bullet(BulletIndex).Line (2, Y - 2)-(X - 2, 2)
        End If
    Else
 '       MsgBox "Application Error: Unknown shape requested!"
        Exit Function
    End If
    Picture1.Refresh
End Function
Private Sub RedDot_Click()
    MARKCOLOR = RGB(255, 0, 0)
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, MARKSHAPE
    End If
    ClearColorChecks
    RedDot.Checked = True
End Sub
Function ClearDots()
    On Error Resume Next
    For i = 1 To maxMarks
        Unload Bullet(i)
        Notes(i) = ""
    Next
    maxMarks = 0
End Function
Function RedrawDots()
    On Error Resume Next
    For i = 1 To maxMarks
        DrawBullet (i), Bullet(i).FillColor, Bullet(i).Tag
    Next
End Function
Private Sub ShapeBox_Click()
    MARKSHAPE = "BOX"
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, MARKSHAPE
    End If
    ClearShapeChecks
    ShapeBox.Checked = True
End Sub
Private Sub ShapeCircle_Click()
    MARKSHAPE = "CIRCLE"
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, "CIRCLE"
    End If
    ClearShapeChecks
    ShapeCircle.Checked = True
End Sub
Private Sub ShapeDot_Click()
    MARKSHAPE = "DOT"
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, MARKSHAPE
    End If
    ClearShapeChecks
    ShapeDot.Checked = True
End Sub
Private Sub ShapeXBox_Click()
    MARKSHAPE = "XBOX"
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, "XBOX"
    End If
    ClearShapeChecks
    ShapeXBox.Checked = True
End Sub
Private Sub ShowNotes_Click()
On Error Resume Next
    Picture1.AutoRedraw = False
    For i = 1 To maxMarks
        Picture1.CurrentX = Bullet(i).Left + Bullet(i).ScaleWidth
        Picture1.CurrentY = Bullet(i).Top
        Picture1.Print Notes(i)
    Next
    Picture1.AutoRedraw = True
End Sub
Private Sub WhiteDot_Click()
    MARKCOLOR = RGB(255, 255, 255)
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, Bullet(selDotIndex).Tag
    End If
    ClearColorChecks
    WhiteDot.Checked = True
End Sub
Private Sub YellowDot_Click()
    MARKCOLOR = RGB(255, 255, 0)
    If selDotIndex = -1 Then
        Exit Sub
    Else
        DrawBullet selDotIndex, MARKCOLOR, Bullet(selDotIndex).Tag
    End If
    ClearColorChecks
    YellowDot.Checked = True
End Sub
Sub ClearShapeChecks()
    ShapeBox.Checked = False
    ShapeDot.Checked = False
    ShapeCircle.Checked = False
    ShapeXBox.Checked = False
End Sub
Sub ClearColorChecks()
    RedDot.Checked = False
    GreenDot.Checked = False
    BlueDot.Checked = False
    WhiteDot.Checked = False
    BlackDot.Checked = False
    YellowDot.Checked = False
End Sub