VB 5/6-Tipp 0707: Zoom per SetViewportExtent
von Klaus Langbein
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: | Verwendete API-Aufrufe: GetDC, GetMapMode, GetViewportExtEx, GetWindowDC, GetWindowExtEx, SetMapMode, SetViewportExtEx, SetViewportOrgEx, SetWindowExtEx | Download: |
'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-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | |||||||
VB5 | |||||||
VB6 |
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.