Hvordan lage en box i en PictureControl?

[Hayer]

Hei

Hvordan får jeg laget en boks i en picture kontroll der brukeren klikker skal høyre jørne være. Så kommer resten av seg selv. Er det også mulig og få til at man selv kan dra opp størrelsen på boksen med musa?

[aadnk]

Kanskje noe så som dette?

Option Explicit

 

' De ulike koordinatene til rektangelene

Private Type RECT

    Left As Long

    Top As Long

    Right As Long

    Bottom As Long

End Type

 

' Hvilken boks brukeren for øyeblikket redigerer

Private CurrentIndex As Long

 

' En array som inneholder alle nåværende bokser

Private aBoxes() As RECT

Private aCount As Long

 

' Legg til en ny boks

Private Function AddBox(refRect As RECT) As Long

 

    ' Realloker array til å passe antallet med bokser

    ReDim Preserve aBoxes(aCount)

   

    ' Sett verdiene

    LSet aBoxes(aCount) = refRect

   

    ' Returner indeksen til den nyskapte boksen

    AddBox = aCount

   

    ' Øk teller

    aCount = aCount + 1

 

End Function

 

' Tegner alle retangler i bildeboksen

Private Sub DrawAll(refPicture As PictureBox)

 

    Dim Tell As Long

   

    ' Fjern alle tidligere opptegniner

    refPicture.Cls

   

    ' Gå gjennom alle elementer, ...

    For Tell = 0 To aCount - 1

   

        ' ... sett tegnemåten (makrerte elementer tegnes med strekete linjer - kan forandres siden)

        refPicture.DrawStyle = IIf(Tell = CurrentIndex, vbDot, vbSolid)

   

        ' Tegn rektangelet i bildeboksen

        refPicture.Line (aBoxes(Tell).Left, aBoxes(Tell).Top)-(aBoxes(Tell).Right, _

        aBoxes(Tell).Bottom), refPicture.ForeColor, B

   

    Next

 

End Sub

 

' Benyttet kun for å forenkle initialiseringen av en Type

Private Function CreateRect(Left As Long, Top As Long, Right As Long, Bottom As Long) As RECT

 

    ' Initialiser rektangel

    With CreateRect

        .Left = Left

        .Top = Top

        .Right = Right

        .Bottom = Bottom

    End With

 

End Function

 

Private Function IsValid(ByVal Index As Long) As Boolean

   

    ' Returnerer hvorvidt den angitte indeks befinner seg i arrayen

    IsValid = CBool(Index >= 0 And Index < aCount)

 

End Function

 

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

 

    ' Lag en ny boks om angitt

    If Button = 1 Then ' Venstre musetast

   

        ' Lag en ny boks på denne lokalisasjonen

        CurrentIndex = AddBox(CreateRect(CLng(X), CLng(Y), CLng(X), CLng(Y)))

       

    End If

 

End Sub

 

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

 

    ' Dersom det nåværende markerte elementet er gyldig og en musetast nedtrykkes, ...

    If IsValid(CurrentIndex) And (Button = 1) Then

   

        ' ... sett de to andre koordinatene i bildeboksen.

        With aBoxes(CurrentIndex)

            .Right = X

            .Bottom = Y

        End With

   

        ' Tegn alle bokser

        DrawAll picBoard

   

    End If

 

End Sub

 

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

 

    ' Dersom vi har en nåværende markert boks, ...

    If IsValid(CurrentIndex) Then

   

        ' ... er det opplagt at brukeren er ferdig med seleksjonen. Avmarker.

        CurrentIndex = -1

       

        ' Tegn alle bokser

        DrawAll picBoard

   

    End If

 

End Sub

 

Private Sub picBoard_Paint()

 

    ' *** Ikke nødvendig dersom du har picBoard.AutoRedraw = True ***

    DrawAll picBoard

 

End Sub

Nå var du nokså uklar i hva du ønsket å bruke dette til, så jeg satset på at ikke ønsket en tegneprosedyre, men heller lage "reelle" objekter som siden kan markeres, redigeres og slettes.

[backup]

Er det også mulig og få til at man selv kan dra opp størrelsen på boksen med musa?

 

Ja, og her har du et eksempel på dette i vb 6:

Sett en picturebox (picture1) på formen. Nede i høyre hjørne av picture1, sett en picturebox (picture2) som en liten firkant med f.eks. backcolor = vbred. Lim så inn koden nedenfor. Kjør prosjektet, venstreklikk formen, og picture1 dukker opp som du vil ha den. Holde musa nede på den røde picture2 og trekk som du vil. Du ser picture1 sin størrelse endrer seg. Venstreklikk formen på nytt, og picture1 dukker igjen opp som du vil ha den. Høyreklikk formen, og picture1 forsvinner, venstreklikk formen etc.

 

Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Const WM_NCLBUTTONDOWN = &HA1

Const HTBOTTOMRIGHT = 17

Private Sub Form_Load()

Picture1.Visible = False

Picture2.BackColor = vbRed

End Sub

 

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

If Button = 1 Then

Picture1.Left = X - Picture1.Width

Picture1.Top = Y - Picture1.Height

Picture1.Visible = True

Else

Picture1.Visible = False

End If

End Sub

 

Private Sub Picture1_Resize()

Picture2.Left = Picture1.Width - Picture2.Width

Picture2.Top = Picture1.Height - Picture2.Height

End Sub

 

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

ReleaseCapture

SendMessage Picture1.hwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0

End Sub