frmmain.frm

这是个不错的源程序

        frmSelect.lblMain.Caption = "需要把图片保存到哪里?"
        frmSelect.Show 1
        Select Case sChoice
            Case "P"
            cdMain.ShowSave
            If cdMain.FileTitle <> "" Then
                SavePicture aspbMaster.Picture, cdMain.FileName
            End If
            Case "C"
            cdMain.ShowSave
            If cdMain.FileTitle <> "" Then
                SavePicture aspbChild.Picture, cdMain.FileName
            End If
        End Select
        Case "Print"
        frmSelect.Caption = "打印"
        frmSelect.lblMain.Caption = "需要打印图片?"
        frmSelect.Show 1
        Select Case sChoice
            Case "P"
            Printer.PaintPicture aspbMaster.Picture, 0, 0, Printer.ScaleWidth, Printer.ScaleHeight
            Printer.EndDoc
            Case "C"
            Printer.PaintPicture aspbChild.Picture, 0, 0, Printer.ScaleWidth, Printer.ScaleHeight
            Printer.EndDoc
        End Select
        Case "Camera"
        cmdStart_Click
        Case "Help"

        Case "Mask"
        If Toolbar1.Buttons(9).Value = tbrUnpressed Then
            Toolbar1.Buttons(9).Value = tbrPressed
            bMask = True
        Else
            Toolbar1.Buttons(9).Value = tbrUnpressed
            bMask = False
        End If
        Case "DelMask"
        frmSelect.Caption = "删除屏蔽色"
        frmSelect.lblMain.Caption = "移除屏蔽色?"
        frmSelect.Show 1
        On Error GoTo endErr
        Select Case sChoice
            Case "P"
            lstMaster.Clear
            Kill Left$(sMFile, Len(sMFile) - 3) & "msk"
            aspbMaster.PicRefresh
            Case "C"
            lstChild.Clear
            Kill Left$(sCFile, Len(sCFile) - 3) & "msk"
            aspbChild.PicRefresh
        End Select
endErr:
    End Select
End Sub

Private Sub AutoResizer1_DragDrop(Source As Control, X As Single, Y As Single)

End Sub

Private Sub cmdChild_Click()

    cdMain.ShowOpen

    If cdMain.FileName = "" Then Exit Sub

    aspbChild.Picture = LoadPicture(cdMain.FileName)
    picChild.Picture = LoadPicture(cdMain.FileName)
    picChildHidden.Picture = LoadPicture(cdMain.FileName)
    sCFile = cdMain.FileName
    lstChild.Clear
    sTmp = Left$(sCFile, Len(sCFile) - 3) & "msk"
    lstChild.Clear
    If Dir(sTmp, vbNormal) <> "" Then
        'load mask
        bCMask = True
        Dim tx As Single, ty As Single, tx1 As Single, ty1 As Single
        Open sTmp For Input As #1

        Line Input #1, one$
        lstChild.AddItem one$
        tx = Split(one$, ",")(0)
        ty = Split(one$, ",")(1)
        tx1 = Split(one$, ",")(2)
        ty1 = Split(one$, ",")(3)
        aspbChild.DoLine tx, ty, tx1, ty1

        Do Until EOF(1)
            Line Input #1, one$
            lstChild.AddItem one$
            tx = Split(one$, ",")(0)
            ty = Split(one$, ",")(1)
            tx1 = Split(one$, ",")(2)
            ty1 = Split(one$, ",")(3)
            aspbChild.DoLine tx, ty, tx1, ty1
        Loop

        Close #1
    Else
        bCMask = False
    End If

End Sub

Private Sub cmdMaster_Click()

    cdMain.ShowOpen

    If cdMain.FileName = "" Then Exit Sub

    aspbMaster.Picture = LoadPicture(cdMain.FileName)
    picMaster.Picture = LoadPicture(cdMain.FileName)
    picMasterHidden.Picture = LoadPicture(cdMain.FileName)
    sMFile = cdMain.FileName
    lstMaster.Clear
    sTmp = Left$(sMFile, Len(sMFile) - 3) & "msk"
    lstMaster.Clear
    If Dir(sTmp, vbNormal) <> "" Then
        'load mask
        bPMask = True
        Dim tx As Single, ty As Single, tx1 As Single, ty1 As Single
        Open sTmp For Input As #1

        Line Input #1, one$
        lstMaster.AddItem one$
        tx = Split(one$, ",")(0)
        ty = Split(one$, ",")(1)
        tx1 = Split(one$, ",")(2)
        ty1 = Split(one$, ",")(3)
        aspbMaster.DoLine tx, ty, tx1, ty1

        Do Until EOF(1)
            Line Input #1, one$
            lstMaster.AddItem one$
            tx = Split(one$, ",")(0)
            ty = Split(one$, ",")(1)
            tx1 = Split(one$, ",")(2)
            ty1 = Split(one$, ",")(3)
            aspbMaster.DoLine tx, ty, tx1, ty1
        Loop

        Close #1
    Else
        bPMask = False
    End If

End Sub

Private Sub cmdStart_Click()

    Screen.MousePointer = 11

    Dim p1 As Long, p2 As Long
    Dim p3 As Long, p4 As Long
    Dim X As Integer, Y As Integer
    Dim bRed As Boolean
    Dim InMask As Boolean
    Dim tx As Single, ty As Single, ty1 As Single, tx1 As Single

    pbMain.Max = picMasterHidden.Height + picChildHidden.Height

    Do

        p1 = picMasterHidden.Point(X, Y)
        p2 = picChildHidden.Point(X, Y)

        If frmMain.lstMaster.ListCount > 0 Then

            For i = 0 To frmMain.lstMaster.ListCount - 1

                one$ = frmMain.lstMaster.List(i)
                tx = Split(one$, ",")(0)
                ty = Split(one$, ",")(1)
                tx1 = Split(one$, ",")(2)
                ty1 = Split(one$, ",")(3)
                If (X >= tx) And (X <= tx1) And (Y >= ty) And (Y <= ty1) Then
                    InMask = True
                    Exit For
                End If
            Next i

        ElseIf frmMain.lstChild.ListCount > 0 Then

            For i = 0 To frmMain.lstChild.ListCount - 1

                one$ = frmMain.lstChild.List(i)
                tx = Split(one$, ",")(0)
                ty = Split(one$, ",")(1)
                tx1 = Split(one$, ",")(2)
                ty1 = Split(one$, ",")(3)
                If (X >= tx) And (X <= tx1) And (Y >= ty) And (Y <= ty1) Then
                    InMask = True
                    Exit For
                End If
            Next i

        End If

        If InMask = False Then
            If p1 = p2 Then
                'pixels match, do nothing
            Else
                If bRed = False Then
                    If p1 <> 255 Then
                        SetPixelV picMasterHidden.hdc, X, Y, vbRed
                    Else
                        SetPixelV picMasterHidden.hdc, X, Y, vbWhite
                    End If
                    bRed = True
                Else
                    bRed = False
                End If

            End If
        End If

        InMask = False

        If X < picMasterHidden.Width Then
            X = X + 1
        Else
            X = 0
            Y = Y + 1
            If Y > picMasterHidden.Height Then
                Exit Do
            End If
            pbMain.Value = pbMain.Value + 1
        End If
        DoEvents
    Loop

    SavePicture picMasterHidden.Image, App.Path & "\master.bmp"
    picMasterHidden.Picture = picMaster.Image
    InMask = False
    X = 0
    Y = 0

    Do

        p1 = picMasterHidden.Point(X, Y)
        p2 = picChildHidden.Point(X, Y)

        If frmMain.lstMaster.ListCount > 0 Then

            For i = 0 To frmMain.lstMaster.ListCount - 1

                one$ = frmMain.lstMaster.List(i)
                tx = Split(one$, ",")(0)
                ty = Split(one$, ",")(1)
                tx1 = Split(one$, ",")(2)
                ty1 = Split(one$, ",")(3)
                If (X >= tx) And (X <= tx1) And (Y >= ty) And (Y <= ty1) Then
                    InMask = True
                    Exit For
                End If
            Next i

        ElseIf frmMain.lstChild.ListCount > 0 Then

            For i = 0 To frmMain.lstChild.ListCount - 1

                one$ = frmMain.lstChild.List(i)
                tx = Split(one$, ",")(0)
                ty = Split(one$, ",")(1)
                tx1 = Split(one$, ",")(2)
                ty1 = Split(one$, ",")(3)
                If (X >= tx) And (X <= tx1) And (Y >= ty) And (Y <= ty1) Then
                    InMask = True
                    Exit For
                End If
            Next i

        End If

        If InMask = False Then
            If p1 = p2 Then
                'pixels match, do nothing
            Else
                If bRed = False Then
                    If p1 <> 255 Then
                        SetPixelV picChildHidden.hdc, X, Y, vbRed
                    Else
                        SetPixelV picChildHidden.hdc, X, Y, vbWhite
                    End If
                    bRed = True
                Else
                    bRed = False
                End If

            End If
        End If

        If X < picChildHidden.Width Then
            X = X + 1
        Else
            X = 0
            Y = Y + 1
            If Y > picChildHidden.Height Then
                Exit Do
            End If
            pbMain.Value = pbMain.Value + 1
        End If

    Loop

    SavePicture picChildHidden.Image, App.Path & "\child.bmp"

    aspbMaster.Picture = LoadPicture(App.Path & "\master.bmp")
    aspbChild.Picture = LoadPicture(App.Path & "\child.bmp")

    pbMain.Value = 0

    Screen.MousePointer = 0

End Sub


Private Sub aspbchild_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button = 1 And bMask = True And sCFile <> "" Then
        ix = X
        iy = Y
    End If

End Sub

Private Sub aspbchild_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button = 1 And bMask = True And sCFile <> "" Then
        aspbChild.DoLine ix, iy, X, Y
        Toolbar1.Buttons(9).Value = tbrUnpressed
        bMask = False
        'create subfile for mask
        'assume it has 3 letter extension as normal
        sTmp = Left$(sCFile, Len(sCFile) - 3) & "msk"
        a = aspbChild.VSVal
        B = aspbChild.HSVal
        iy = iy + a
        ix = ix + B
        Y = Y + a
        X = X + B
        If Dir(sTmp, vbNormal) = "" Then
            rtbMain.Text = Str$(ix) & "," & Str$(iy) & "," & Str$(X) & "," & Str$(Y) & vbCrLf
            rtbMain.SaveFile sTmp, rtfText
        Else
            rtbMain.LoadFile sTmp, rtfText
            rtbMain.Text = rtbMain.Text & Str$(ix) & "," & Str$(iy) & "," & Str$(X) & "," & Str$(Y) & vbCrLf
            rtbMain.SaveFile sTmp, rtfText
        End If
        lstChild.AddItem Str$(ix) & "," & Str$(iy) & "," & Str$(X) & "," & Str$(Y) & vbCrLf
    End If

End Sub