Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0707: Zoom per SetViewportExtent

 von 

Beschreibung 

Mit Hilfe der Funktion SetViewportExtEx ist es möglich, den anzuzeigenden Bildausschnitt eines Gerätekontextes zu verändern. Verkleinert man den Viewport gegenüber der Größe des Gerätekontextes, so wird dieser vergrößert dargestellt. Mittels SetViewPortOrigin kann das Bild horizontal und vertikal verschoben werden.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

GetDC, GetMapMode, GetViewportExtEx, GetWindowDC, GetWindowExtEx, SetMapMode, SetViewportExtEx, SetViewportOrgEx, SetWindowExtEx

Download:

Download des Beispielprojektes [28,37 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'------- Anfang Formular "frmZoom" alias frmZoom.frm  -------
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Textfeld "Text1" auf Frame1
' Steuerelement: Vertikale Scrollbar "VScroll2" auf Frame1
' Steuerelement: Beschriftungsfeld "Label1" auf Frame1
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Vertikale Scrollbar "VScroll1"
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "Pic"

' Stufenloser Zoom des Inhalts einer Picturebox
' Autor/Copyright K. Langbein, ActiveVB.de 2005

' Mit Hilfe der Funktion SetViewportExtEx ist es möglich den
' anzuzeigenden Bildausschnitt eines DC zu verändern. Verkleinert
' man den Viewport gegenüber der Größe des DC, so wird dieser
' vergrößert dargestellt. Mittels SetViewPortOrigin kann das Bild
' horizontal und vertikal verschoben werden.

Option Explicit

Private Type Size
    Cx As Long
    Cy As Long
End Type

Private Type PointApi
    x As Long
    y As Long
End Type

Private Const MM_TEXT As Long = 1
Private Const MM_LOMETRIC As Long = 2
Private Const MM_HIMETRIC As Long = 3
Private Const MM_LOENGLISH As Long = 4
Private Const MM_HIENGLISH As Long = 5
Private Const MM_TWIPS As Long = 6
Private Const MM_ISOTROPIC As Long = 7
Private Const MM_ANISOTROPIC As Long = 8

Private Declare Function GetWindowDC Lib "user32.dll" ( _
                 ByVal hwnd As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetViewportExtEx Lib "gdi32.dll" ( _
                         ByVal hDc As Long, lpSize As Size) As Long
                         
Private Declare Function GetWindowExtEx Lib "gdi32.dll" ( _
                         ByVal hDc As Long, lpSize As Size) As Long
                         
Private Declare Function SetViewportExtEx Lib "gdi32" ( _
                         ByVal hDc As Long, ByVal nX As Long, _
                         ByVal nY As Long, lpSize As Size) As Long
                         
Private Declare Function SetViewportOrgEx Lib "gdi32" ( _
                         ByVal hDc As Long, ByVal nX As Long, _
                         ByVal nY As Long, lpPoint As PointApi) As Long
                         
Private Declare Function SetWindowExtEx Lib "gdi32" ( _
                         ByVal hDc As Long, ByVal nX As Long, _
                         ByVal nY As Long, lpSize As Size) As Long

Private Declare Function GetMapMode Lib "gdi32.dll" ( _
                 ByVal hDc As Long) As Long

Private Declare Function SetMapMode Lib "gdi32.dll" ( _
                 ByVal hDc As Long, _
                 ByVal nMapMode As Long) As Long

Dim Zoom As Double
Dim BlockAction  As Boolean
Dim Pig As StdPicture

Sub Scroll()

    Dim P As PointApi
    Dim Sw As Size
    Dim x As Long
    Dim y As Long
    Dim ret As Long
    
    If BlockAction = True Then
        Exit Sub
    End If
  
    x = HScroll1.Value
    y = VScroll1.Value
    ' Koordinatenursprung setzen
    ret = SetViewportOrgEx(Pic.hDc, x, y, P)
    Pic.Refresh
    
End Sub

Sub SetZoom()

    Dim S As Size
    Dim f As Single
    Dim dx As Long
    Dim dy As Long
    Dim w As Long
    Dim h As Long
    Dim ret As Long
  
    ret = SetMapMode(Pic.hDc, MM_ISOTROPIC)
    
    Zoom = VScroll2.Value / 10
    
    ' Differenzen berechnen
    dx = Pic.ScaleWidth * (Zoom - 1) / Zoom
    dy = Pic.ScaleHeight * (Zoom - 1) / Zoom
    If Zoom < 2.1 Then
        dx = dx - 1
        dy = dy - 1
    End If
    
    BlockAction = True ' Vorübergehend Scroll blokieren
    ' Scrollbars entsprechend Zoom und Differenz einstellen
    If dx > 0 Then
        HScroll1.Enabled = True
        HScroll1.Max = dx
        HScroll1.LargeChange = (Pic.ScaleWidth - dx)
    Else
        HScroll1.Enabled = False
        HScroll1.Value = 0
    End If
    If dy > 0 Then
        VScroll1.Enabled = True
        VScroll1.Max = dy
        VScroll1.LargeChange = (Pic.ScaleHeight - dy)
    Else
        VScroll1.Enabled = False
        VScroll1.Value = 0
    End If
    
    BlockAction = False
    
    Text1.Text = Format$(Zoom)
    
    f = 10
    w = Pic.ScaleWidth * f
    h = Pic.ScaleHeight * f
    ' Fenster-Abmessungen mit Faktor f setzen
    ret = SetWindowExtEx(Pic.hDc, w, h, S)
    w = Int(w / Zoom)
    h = Int(h / Zoom)
    ' Viewport-Abmessungen setzen
    ret = SetViewportExtEx(Pic.hDc, w, h, S)
    
    ' Setzen von Origin auslösen
    Call Scroll
    Pic.Refresh
    
End Sub

Private Sub Command1_Click()

    Dim i As Long
    Dim Sh As Long
    Dim Sw As Long
    Dim th As Single
    Dim Txt$
    
    Sw = Pic.ScaleWidth
    Sh = Pic.ScaleHeight
    Pic.Cls
    Set Pic.Picture = Nothing
    HScroll1.Value = HScroll1.Min
    VScroll1.Value = VScroll1.Min
    
    Call SetZoom
    
    ' Testbild zeichnen
    Pic.ForeColor = 0
    Pic.Line (Zoom, Zoom)-((Sw - 2) * Zoom, (Sh - 2) * Zoom), , B
    Pic.ForeColor = vbRed
    Pic.Line (0, 0)-((Sw - 1) * Zoom, (Sh - 1) * Zoom), , B
    Pic.ForeColor = vbGreen
    Pic.Line (0, 0)-((Sw - 0) * Zoom, (Sh - 0) * Zoom)
    Pic.Line ((Sw - 1) * Zoom, 0)-(-1, (Sh - 0) * Zoom)
    Pic.ForeColor = vbBlue
    Pic.CurrentX = 3 * Zoom
    Pic.CurrentY = 3 * Zoom
    Txt$ = "1234567890 1234567890 1234567890 1234567890"
    Txt$ = Txt$ & " 1234567890 1234567890 1234567890 1234567890"
    Pic.Print Txt$

    Pic.CurrentX = 3 * Zoom
    Pic.CurrentY = (Sh - 15) * Zoom
    Pic.Print Txt$
    th = (Pic.TextHeight("H")) * Zoom
    
    For i = 2 To 22
        Pic.CurrentX = 3 * Zoom
        Pic.CurrentY = (i - 1) * th
        Pic.Print Format$(i, "00")
    Next i
    
    For i = 2 To 22
        Pic.CurrentX = (Sw - 16) * Zoom
        Pic.CurrentY = (i - 1) * th
        Pic.Print Format$(i, "00")
    Next i
    
End Sub

Private Sub Command2_Click()

    Pic.Cls
    
    ' Bild wird zunächst bei Zoom = 1 geladen
    Text1.Text = "1"
    Call Text1_KeyDown(13, 0)
    Set Pic.Picture = Pig
    
    ' Anschließend kann ein Zoomfaktor angegeben werden.
    Text1.Text = "2"
    Call Text1_KeyDown(13, 0)
    
End Sub

Private Sub Form_Load()

    Me.ScaleMode = 3
    Pic.AutoRedraw = True
    Pic.ScaleMode = 3

    Pic.Width = 512
    Pic.Height = 302
    
    ' Controls plazieren
    HScroll1.Move Pic.Left, Pic.Top + Pic.Height + 0, Pic.Width
    VScroll1.Move Pic.Left + Pic.Width + 0, Pic.Top, VScroll1.Width, Pic.Height
    Frame1.Left = VScroll1.Left + VScroll1.Width + 15
    HScroll1.Max = 1000
    HScroll1.Min = 0
    HScroll1.Value = 0
    VScroll1.Max = 1000
    VScroll1.Min = 0
    VScroll1.Value = 0
    
    VScroll2.Max = 10
    VScroll2.Min = 320
    
    Set Pig = Pic.Picture ' Bild vom Schwein Zwischenspeichern
    
    Call Command1_Click   ' Zeichnung auslösen
    VScroll2.Value = 20   ' Setzen von Vscroll löst Zoom aus
    
End Sub

Private Sub HScroll1_Change()
    Call Scroll
End Sub

Private Sub HScroll1_Scroll()
    Call Scroll
End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)

    Dim z As Double

    Select Case KeyCode
    Case 13
        z = Val(Text1.Text)
        If z < 1 Then
            z = 1
        End If
        If z > VScroll2.Min / 10 Then
            z = VScroll2.Min / 10
        End If
        VScroll2.Value = z * 10
    Case Else
    
    End Select

End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then KeyAscii = 0
End Sub

Private Sub VScroll1_Change()
    Call Scroll
End Sub

Private Sub VScroll1_Scroll()
    Scroll
End Sub

Private Sub VScroll2_Change()
    Call SetZoom
End Sub

Private Sub VScroll2_Scroll()
    Call SetZoom
End Sub
'-------- Ende Formular "frmZoom" alias frmZoom.frm  --------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.