icon32.frm

VB源程序

    If Shift Then 'ctrl , alt or shift
     'the following allows a straight line
     'while the shift key is down
     If Abs(X - miStartX) > Abs(Y - miStartY) Then
       miMoveY = miStartY \ 150
     Else
       miMoveX = miStartX \ 150
     End If
    End If
    Plot 150 * miMoveX, 150 * miMoveY, c
   
   Case CIRCMODE, CIRCFILLMODE
    Dim radius%
    'compute radius
    radius = Sqr(Abs(miStartX - X) ^ 2 + Abs(miStartY - Y) ^ 2)
    'shCircle is a shape defined as a circle
    'and allows user to preview the circle
    shCircle.Width = 2 * radius
    shCircle.Height = 2 * radius
    shCircle.Left = miStartX - radius
    shCircle.Top = miStartY - radius
   
   Case LINEMODE
    'shLine allows preview of line
    shLine.X1 = miStartX
    shLine.Y1 = miStartY
    shLine.X2 = X
    shLine.Y2 = Y
   
   Case RECTMODE, RECTFILLMODE
    'following two lines allow user to drag box
    'in any direction
    shRect.Left = -miStartX * (X > miStartX) - _
                  X * (X <= miStartX)
    shRect.Top = -miStartY * (Y > miStartY) - _
                  Y * (Y <= miStartY)
    shRect.Width = Abs(miStartX - X)
    shRect.Height = Abs(miStartY - Y)
   
   Case TEXTMODE
    'nothing to do
   
   Case CAPTUREMODE
    'same coding as for rectangle
    'just uses a rectangle shape with dashed border
    shCapture.Left = -miStartX * (X > miStartX) - _
                  X * (X <= miStartX)
    shCapture.Top = -miStartY * (Y > miStartY) - _
                  Y * (Y <= miStartY)
    shCapture.Width = Abs(miStartX - X)
    shCapture.Height = Abs(miStartY - Y)
  End Select
 End If     'if Button
End Sub

'This is where the actual drawing occurs.  When
' this is fired, miStartX/miStartY define where
' the mouse went down and X/Y define where
' it is now
Private Sub grid_MouseUp(Button As Integer, _
 Shift As Integer, X As Single, Y As Single)
 
 Dim c&
 'get color for subsequent ops
 If Button = 1 Then
    c = LeftColor.BackColor
 Else
    c = RightColor.BackColor
 End If
 
 Select Case miMode
  
  Case CIRCMODE, CIRCFILLMODE
   If miMode = CIRCMODE Then
    Ikon.FillStyle = 1  'unfilled
   Else
    Ikon.FillStyle = 0  'filled
   End If
   Ikon.FillColor = c
    'radius is just shCircle's width or height / 2
   Ikon.Circle (miStartX \ 150, miStartY \ 150), shCircle.Width / 300, c
   Ikon2Grid
   'setting the shapes & lines to minimum
   'height/width precludes having them jump
   'back to previous size when made visible again
   shCircle.Width = 0
   shCircle.Height = 0
   shCircle.Visible = False
  
  Case LINEMODE
   'shLine is actually a line and not a shape
   ' its X1,Y1,X2,Y2 properties make it easy
   ' to define the line parameters
   Ikon.Line (shLine.X1 \ 150, shLine.Y1 \ 150)-(shLine.X2 \ 150, shLine.Y2 \ 150), c
   'the line drawing routine does not set the
   ' final point, so the following is necessary
   Ikon.PSet (shLine.X2 \ 150, shLine.Y2 \ 150), c
   Ikon2Grid
   shLine.X1 = 0: shLine.Y1 = 0: shLine.X2 = 0: shLine.Y2 = 0
   shLine.Visible = False
  
  Case RECTMODE, RECTFILLMODE
   If miMode = RECTMODE Then
     'for some reason, vbTransparent
     'equates to zero, so...
     Ikon.FillStyle = 1
     Ikon.Line (miStartX \ 150, miStartY \ 150)-(X \ 150, Y \ 150), c, B
   Else
     Ikon.FillStyle = vbSolid
     Ikon.Line (miStartX \ 150, miStartY \ 150)-(X \ 150, Y \ 150), c, BF
   End If
   Ikon2Grid
   shRect.Width = 0: shRect.Height = 0
   shRect.Visible = False
  
  Case TEXTMODE
   'try to center the letter on the mouseup coord
   Ikon.CurrentX = X \ 150 - (Ikon.TextWidth(txtAlpha)) / 2
   Ikon.CurrentY = Y \ 150 - (Ikon.TextHeight(txtAlpha)) / 2
   Ikon.ForeColor = c
   Ikon.Print txtAlpha
   Ikon2Grid
  
  Case FLOODMODE
   'I've tried many times to write a flood fill
   ' routine with little success.  The API call
   ' below does it well
   Dim Result&
   Ikon.FillStyle = vbSolid
   Ikon.FillColor = c
   Ikon.Picture = Ikon.Image
   Result = ExtFloodFill(Ikon.hdc, miStartX \ 150, _
            miStartY \ 150, _
            Ikon.Point(X \ 150, Y \ 150), _
            FLOODFILLSURFACE)
   Ikon2Grid
  
  Case CAPTUREMODE
   cmdCopy.Enabled = True
   cmdCut.Enabled = True
  
  Case PASTEMODE
   'This could be simplified by having the
   'cmdCut & cmdCopy routines define
   'miCapWidth & miCapHeight
   Ikon.PaintPicture picCap.Image, X \ 150, Y \ 150, _
    miCapX2 - miCapX1 + 1, miCapY2 - miCapY1 + 1, _
    0, 0, miCapX2 - miCapX1 + 1, miCapY2 - miCapY1 + 1
   Ikon2Grid
   shCapture.Width = 0: shCapture.Height = 0
   shCapture.Visible = False
 
 End Select
End Sub

Private Sub mnuFileExit_Click()
 'Here, if desired, one could add some code
 'to see if the user wants to save the drawing.
 
 Unload Me      'fini
End Sub

Private Sub mnuFileOpen_Click()
 cd.Filter = "Icon Files (*.ico)|*.ico"
 cd.ShowOpen
 If Err <> 32755 Then
  Caption = "Icon32 - " & cd.filename
  Ikon.Picture = LoadPicture(cd.filename)
  Ikon2Grid
 End If
End Sub
'Workhorse routine: transfers ikon's picture
' to the grid
Private Sub Ikon2Grid()
 Dim X%, Y%
 For Y = 0 To 31
  For X = 0 To 31
   Plot 150 * X, 150 * Y, Ikon.Point(X, Y)
  Next
 Next
End Sub

Private Sub mnuFileSave_Click()
 Dim nam$
 nam = cd.filename
 cd.Filter = "Icon Files (*.ico)|*.ico"
 cd.Flags = cdlOFNOverwritePrompt
 cd.ShowSave
 If Err <> 32755 Then 'i.e. if user didn't cancel
    If nam <> cd.filename Then
       Caption = "Icon32 - " & cd.filename
    End If
    Ikon.Picture = Ikon.Image
    SavePicture Ikon.Picture, cd.filename
 End If
End Sub
'This one's fairly self-explanatory
Private Sub cmdShift_Click(Index As Integer)
 Select Case Index
  Case 0
   ShiftRight
  Case 1
   ShiftLeft
  Case 2
   ShiftUp
  Case 3
   ShiftDown
  Case 4
   ShiftUp
   ShiftLeft
  Case 5
   ShiftUp
   ShiftRight
  Case 6
   ShiftDown
   ShiftLeft
  Case 7
   ShiftDown
   ShiftRight
 End Select
 Ikon2Grid
End Sub
'This and the following 6 routines just
'took a little math trial & error
Private Sub ShiftRight()
 Dim X%, Y%
   For Y = 0 To 31
   For X = 31 To 1 Step -1
    Ikon.PSet (X, Y), Ikon.Point(X - 1, Y)
   Next
   Ikon.PSet (0, Y), QBColor(15)
   Next
End Sub
Private Sub ShiftLeft()
 Dim X%, Y%
   For Y = 0 To 31
   For X = 0 To 30
    Ikon.PSet (X, Y), Ikon.Point(X + 1, Y)
   Next
   Ikon.PSet (31, Y), QBColor(15)
   Next
End Sub
Private Sub ShiftUp()
 Dim X%, Y%
   For X = 0 To 31
   For Y = 0 To 30
    Ikon.PSet (X, Y), Ikon.Point(X, Y + 1)
   Next
   Ikon.PSet (X, 31), QBColor(15)
   Next
End Sub
Private Sub ShiftDown()
 Dim X%, Y%
   For X = 0 To 31
   For Y = 31 To 1 Step -1
    Ikon.PSet (X, Y), Ikon.Point(X, Y - 1)
   Next
   Ikon.PSet (X, 0), QBColor(15)
   Next
End Sub

Private Sub cmdFlipH_Click()
 Dim X%, Y%, w&(0 To 31, 0 To 31)
 For Y = 0 To 31
  For X = 0 To 31
   w(X, Y) = Ikon.Point(X, Y)
  Next
 Next
 For Y = 0 To 31
  For X = 31 To 0 Step -1
   Ikon.PSet (X, Y), w(31 - X, Y)
  Next
 Next
 Ikon2Grid

End Sub

Private Sub cmdFlipV_Click()
 Dim X%, Y%, w&(0 To 31, 0 To 31)
 For Y = 0 To 31
  For X = 0 To 31
   w(X, Y) = Ikon.Point(X, Y)
  Next
 Next
 For Y = 31 To 0 Step -1
  For X = 0 To 31
   Ikon.PSet (X, Y), w(X, 31 - Y)
  Next
 Next
 Ikon2Grid
End Sub

Private Sub cmdRotate_Click()
 Dim X%, Y%, w&(0 To 31, 0 To 31)
 For Y = 0 To 31
  For X = 0 To 31
   w(X, Y) = Ikon.Point(X, Y)
  Next
 Next
 For Y = 0 To 31
  For X = 0 To 31
   Ikon.PSet (Y, X), w(X, Y)
  Next
 Next
 Ikon2Grid
End Sub


Private Sub cmdClear_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Dim c&
 If Button = 1 Then
  c = LeftColor.BackColor
 Else
  c = RightColor.BackColor
 End If
 Ikon.Line (0, 0)-(31, 31), c, BF
 Ikon2Grid
End Sub

Private Sub cmdCopy_Click()
 cmdPaste.Enabled = True
 cmdCopy.Enabled = False
 cmdCut.Enabled = False
 With shCapture
  .Visible = False
  miCapX1 = .Left \ 150
  miCapY1 = .Top \ 150
  miCapX2 = (.Left + .Width) \ 150
  miCapY2 = (.Top + .Height) \ 150
 End With
 picCap.Cls
 picCap.PaintPicture Ikon.Image, 0, 0, miCapX2 - miCapX1 + 1, miCapY2 - miCapY1 + 1, miCapX1, miCapY1, miCapX2 - miCapX1 + 1, miCapY2 - miCapY1 + 1
End Sub

Private Sub cmdCut_Click()
 cmdCopy_Click
 Ikon.Line (miCapX1, miCapY1)-(miCapX2, miCapY2), QBColor(15), BF
 Ikon2Grid
End Sub

Private Sub cmdPaste_Click()
 picMode.Picture = cmdPaste.Picture
 cmdCopy.Enabled = False
 cmdCut.Enabled = False
 miMode = PASTEMODE
End Sub

Private Sub cmdGrid_Click()
 If cmdGrid.Caption = "&Grid" Then
  cmdGrid.Caption = "&No Grid"
  Dim i%
  For i = 0 To 31   'draw the grid
   grid.Line (0, 150 * i)-(4799, 150 * i), 0
   grid.Line (150 * i, 0)-(150 * i, 4799), 0
  Next
 Else
  cmdGrid.Caption = "&Grid"
  grid.Cls          'clear out everything
  Ikon2Grid         'redraw the picture
 End If
End Sub

Private Sub cmdFont_Click()
 cd.Flags = cdlCFBoth Or cdlCFEffects
 'show printer & screen fonts
 cd.FontName = "Ms Sans Serif"
 cd.ShowFont
 If Err <> 32755 Then
  cmdFont.Caption = cd.FontName
  
  txtAlpha.Font = cd.FontName
  txtAlpha.ForeColor = cd.Color
  txtAlpha.FontItalic = cd.FontItalic
  txtAlpha.FontBold = cd.FontBold
  'could also change the textbox fontsize
  'but would require manipulating its height
  
  
  Ikon.Font = cd.FontName
  Ikon.FontSize = cd.FontSize
  Ikon.FontItalic = cd.FontItalic
  Ikon.FontBold = cd.FontBold
 End If
End Sub

Private Sub picModeSel_Click(Index As Integer)
 'handles a click on any of the modes
 miMode = Index
 picMode.Picture = picModeSel(Index).Picture
 SBar.Panels(1).Text = picModeSel(Index).ToolTipText
 UpdateSBar
 cmdPaste.Enabled = False
 cmdCut.Enabled = False
 cmdCopy.Enabled = False
 shCapture.Visible = False
   'in case the user selected an area, then
   ' changed modes
End Sub

Private Sub txtAlpha_GotFocus()
 'saves the user a mouseclick
 picModeSel_Click TEXTMODE
End Sub