USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  Dicas

  Visual Basic    (ActiveX/Controles/DLL)

Título da Dica:  Zoom em Picture box
Postada em 18/4/2006 por Geronimo            
Para testar desenhe 2 pictureboxes, 1 commandbutton e 1 textbox num form vazio e cole o seguinte código:

Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal NWidth As Long, ByVal NHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal hStretchMode As Long) As Long

Const STRETCHMODE = vbPaletteModeNone

Private Sub Form_Load()

    Picture1.BorderStyle = 0
    Picture1.AutoRedraw = True
    Picture2.AutoRedraw = True
    Picture1.AutoSize = True
    ' Troque para a sua imagem
    Picture1.Picture = LoadPicture("C:imagem.gif")
    Command1.Caption = "Redimensiona"
    Text1.Text = "100"
    
End Sub

Sub Redimensiona(picOrigem As PictureBox, picDestino As PictureBox, NWidth As Long, NHeight As Long)

    Dim OrigWdt As Long
    Dim OrigHgt As Long
    
    OrigWdt = picOrigem.Width / Screen.TwipsPerPixelX
    OrigHgt = picOrigem.Height / Screen.TwipsPerPixelY
    
    SetStretchBltMode picDestino.hdc, STRETCHMODE
    StretchBlt picDestino.hdc, 0, 0, NWidth, NHeight, picOrigem.hdc, 0, 0, OrigWdt, OrigHgt, vbSrcCopy
    picDestino.Refresh

End Sub

Private Sub Command1_Click()

    Dim NX As Long
    Dim NY As Long
    Dim P As Integer
    Dim PW As Long
    Dim PH As Long
    
    ' Pega o fator do zoom (em porcentagem)
    P = Val(Text1)
    If P < 1 Then Exit Sub
    
    ' Converte os valores de himetric pra pixel
    PW = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
    PH = ScaleX(Picture1.Picture.Height, vbHimetric, vbPixels)

    ' Calcula o tamanho
    NX = (PW * P) / 100
    NY = (PH * P) / 100
    
    ' Zera a imagem destino
    Set Picture2.Picture = LoadPicture("")
    ' Copia
    Redimensiona Picture1, Picture2, NX, NY
    
End Sub

 


CyberWEB Network Ltda.    © Copyright 2000-2021   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página