icon32.frm

VB源程序

      Width           =   255
   End
   Begin VB.PictureBox Color 
      BackColor       =   &H00FFC0C0&
      Height          =   255
      Index           =   7
      Left            =   5640
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   10
      Top             =   1920
      Width           =   255
   End
   Begin VB.PictureBox Color 
      BackColor       =   &H00FFC0FF&
      Height          =   255
      Index           =   6
      Left            =   5400
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   9
      Top             =   1920
      Width           =   255
   End
   Begin VB.PictureBox Color 
      BackColor       =   &H00FFFFC0&
      Height          =   255
      Index           =   5
      Left            =   5160
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   8
      Top             =   1920
      Width           =   255
   End
   Begin VB.PictureBox Color 
      BackColor       =   &H00C0FFC0&
      Height          =   255
      Index           =   4
      Left            =   4920
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   7
      Top             =   1920
      Width           =   255
   End
   Begin VB.PictureBox Color 
      BackColor       =   &H00C0FFFF&
      Height          =   255
      Index           =   3
      Left            =   5640
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   6
      Top             =   1680
      Width           =   255
   End
   Begin VB.PictureBox Color 
      BackColor       =   &H00C0E0FF&
      Height          =   255
      Index           =   2
      Left            =   5400
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   5
      Top             =   1680
      Width           =   255
   End
   Begin VB.PictureBox Color 
      BackColor       =   &H00C0C0FF&
      Height          =   255
      Index           =   1
      Left            =   5160
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   4
      Top             =   1680
      Width           =   255
   End
   Begin VB.PictureBox Color 
      BackColor       =   &H00FFFFFF&
      Height          =   255
      Index           =   0
      Left            =   4920
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   3
      Top             =   1680
      Width           =   255
   End
   Begin VB.PictureBox RightColor 
      BackColor       =   &H80000009&
      Height          =   495
      Left            =   5400
      ScaleHeight     =   435
      ScaleWidth      =   435
      TabIndex        =   2
      ToolTipText     =   "Right Button Color"
      Top             =   1200
      Width           =   495
   End
   Begin VB.PictureBox LeftColor 
      BackColor       =   &H80000007&
      Height          =   495
      Left            =   4920
      ScaleHeight     =   435
      ScaleWidth      =   435
      TabIndex        =   1
      ToolTipText     =   "Left Button Color"
      Top             =   1200
      Width           =   495
   End
   Begin VB.PictureBox grid 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   4832
      Left            =   0
      ScaleHeight     =   4800
      ScaleWidth      =   4800
      TabIndex        =   0
      Top             =   1200
      Width           =   4832
      Begin VB.Shape shCapture 
         BorderColor     =   &H00FF0000&
         BorderStyle     =   4  'Dash-Dot
         Height          =   495
         Left            =   2160
         Top             =   1560
         Visible         =   0   'False
         Width           =   375
      End
      Begin VB.Shape shRect 
         Height          =   15
         Left            =   0
         Top             =   0
         Visible         =   0   'False
         Width           =   15
      End
      Begin VB.Line shLine 
         Visible         =   0   'False
         X1              =   0
         X2              =   0
         Y1              =   0
         Y2              =   0
      End
      Begin VB.Shape shCircle 
         Height          =   15
         Left            =   1320
         Shape           =   3  'Circle
         Top             =   1800
         Visible         =   0   'False
         Width           =   15
      End
   End
   Begin VB.Label Label5 
      Caption         =   "Text:"
      Height          =   255
      Left            =   5640
      TabIndex        =   32
      Top             =   285
      Width           =   735
   End
   Begin VB.Label Label4 
      Caption         =   "Clip"
      Height          =   255
      Left            =   5520
      TabIndex        =   28
      Top             =   5520
      Width           =   495
   End
   Begin VB.Label Label1 
      Caption         =   "Icon"
      Height          =   255
      Left            =   5520
      TabIndex        =   21
      Top             =   5040
      Width           =   615
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuFileOpen 
         Caption         =   "&Open"
      End
      Begin VB.Menu mnuFileSave 
         Caption         =   "&Save"
      End
      Begin VB.Menu mnuFileExit 
         Caption         =   "&Exit"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'***********************************************

'     Many thanks to Burt Abreau and his fine
'     website (www.vbexplorer.com) for pointing
'     me in the right direction.

'***********************************************

'        Written in Visual Basic 5.0


'Hello fellow VB programmers.  Like many projects,
'this grew out of a need for an icon designer that
'would do what I wanted it to do--vice what someone
'else had in mind.  I had been working on another
'project which needed customized icons.  I searched
'the net but couldn't find an icon editor that
'would do what I wanted, so I put the other project
'on hold while I wrote this.  It started out bare
'bones, but you know how that goes.

'I didn't write a help file but here are some notes,
'not in any order:

'(1) Note that a doubleclick on the last 16 color
'boxes will let you define your own color.

'(2) The first 16 colors are solid colors and
'react to all modes normally.  However, the 2nd
'group contains mixed colors & you will see the
'results if you draw a solid shape or clear to
'those colors.

'(3) The Clear command button clears to the left
'color if left clicked & vice versa.

'(4) I beat myself to death trying to get the
'ExtFloodFill API call to work until I finally
'figured out that you have to invoke
'      Picture1.Picture = Picture1.Image
'---whatever that does.

'(5) I think ICONWRKS, which came with VB3 would do
'what I wanted, but in spite of my tweaking & converting
'to 32 bit, it 'illegal ops' on the GetBitMapBits call.
'Anyone know how to fix it?

'Do what you want with this source, however check it
'out carefully before you run it.  I cannot know about
'every person's PC setup & will not be held liable
'if it locks up your machine and wipes out your drive.
'I sincerely doubt this will happen, but who knows?

'Questions/comments to me (Norm Cook):

'          [e-mail]

'Be happy in your programming

Option Explicit
Private Declare Function ExtFloodFill Lib "gdi32" _
 (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
  ByVal crColor As Long, ByVal wFillType As Long) As Long
Const FLOODFILLSURFACE = 1

Dim miStartX%, miStartY%  'define position at mousedown
Dim miMoveX%, miMoveY%    '  "      "       " mousemove
Dim miCapX1%, miCapY1%    'define capture coordinates
Dim miCapX2%, miCapY2%
Dim miMode%               'mode

Const PENCILMODE = 0
Const LINEMODE = 1
Const RECTMODE = 2
Const RECTFILLMODE = 3
Const CIRCMODE = 4
Const CIRCFILLMODE = 5
Const TEXTMODE = 6
Const FLOODMODE = 7
Const CAPTUREMODE = 8
Const PASTEMODE = 9

Private Sub Form_Load()
 Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
 Init
 picModeSel_Click 0       'set pencil mode
 cmdGrid_Click      'remove to start up without grid
  
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 'clear out grid coordinates when mouse leaves grid
 SBar.Panels(3).Text = ""
 UpdateSBar
End Sub

Private Sub Form_Unload(Cancel As Integer)
 Set frmMain = Nothing    'return memory to system
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
 Unload Me
End Sub

Private Sub Init()
 Dim i%
 
 For i = 0 To 15
  Color(i).BackColor = QBColor(i)
 Next
 For i = 31 To 47
  Color(i).ToolTipText = "Doubleclick for custom colors"
 Next
 SBar.Panels.Add
 SBar.Panels.Add
 SBar.Panels(1).Width = Width * 0.7
 SBar.Panels(2).Width = Width * 0.1
 SBar.Panels(3).Width = Width * 0.2
 UpdateSBar
 
End Sub
Private Sub UpdateSBar()
 SBar.Panels(2).Text = Format$(Now, "short time")
End Sub
'Used to plot a square on the main grid
' as well as the ikon
Private Sub Plot(ByVal X%, ByVal Y%, ByVal c&)
 If cmdGrid.Caption = "&Grid" Then
    'without grid=>larger box
  grid.Line (X, Y)-(X + 140, Y + 140), c, BF
 Else
    'with grid=>smaller, so that grid lines visible
  grid.Line (X + 10, Y + 10)-(X + 130, Y + 130), c, BF
 End If
 Ikon.PSet (X \ 150, Y \ 150), c
End Sub

Private Sub Color_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
 'color select
 If Button = 1 Then
  LeftColor.BackColor = Color(Index).BackColor
 Else
  RightColor.BackColor = Color(Index).BackColor
 End If
End Sub
Private Sub Color_DblClick(Index As Integer)
 If Index > 31 Then
  cd.ShowColor
  If Err <> 32755 Then
   Color(Index).BackColor = cd.Color
  End If
 End If
End Sub

'These 3 routines, mousedown, mousemove & mouseup
' are the meat of the program

Private Sub grid_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Dim c&
 miStartX = X: miStartY = Y
  'get color for subsequent ops
 If Button = 1 Then c = LeftColor.BackColor Else c = RightColor.BackColor
 
 Select Case miMode
  
  Case PENCILMODE
   Plot 150 * miMoveX, 150 * miMoveY, c
  
  Case CIRCMODE, CIRCFILLMODE
   shCircle.Visible = True
  
  Case LINEMODE
   shLine.Visible = True
  
  Case RECTMODE, RECTFILLMODE
   shRect.Visible = True
  
  Case TEXTMODE
  
  Case CAPTUREMODE
   shCapture.Visible = True
 
 End Select
End Sub
Private Sub grid_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Dim strx$, stry$
 UpdateSBar
 grid.MousePointer = vbCrosshair
 
 miMoveX = X \ 150: miMoveY = Y \ 150
 
 'build coordinates message for status bar
 strx = "X: " & Right$("0" & CStr(miMoveX), 2)
 stry = "Y: " & Right$("0" & CStr(miMoveY), 2)
 SBar.Panels(3).Text = strx & "       " & stry
 
 If Button Then 'nothing else happens if mouse
  Dim c&        ' not being dragged
  If Button = 1 Then  'left button
   c = LeftColor.BackColor
  Else
   c = RightColor.BackColor
  End If
  
  Select Case miMode
   
   Case PENCILMODE
    'having pencilmode in the mousemove event
    'allows freehand draw