Fóruns
Microsoft Excel - 2...
2024 - Fórmulas Ava...
Aumentar a fonte ao...
 
Notifications
Clear all

Aumentar a fonte ao passar o mouse

 
2024 - Fórmulas Avançadas - Funções Microsoft Excel
7 Posts
3 Usuários
0 Reactions
2,097 Visualizações
RSS
 giovaniazoni
(@giovaniazoni)
Posts: 23
Eminent Member
Topic starter
 

Srs. Bom dia!!

Existira alguma maneira de aumentar a fonte tipo uma lupa na celular em qual passamos o mouse??

Ou fazer que o comentário seja exibido conforme o valor da celular?? É que utilizo uma planilha muito pequena

para poder enxergar tudo de uma vez e necessito ver os valores em si contido, como possui formula, o valor em si

da celular vai estar mostrando a formula e sinceramente é muito trabalhoso ficar dando zoom in e zoom out, existiria

alguma maneira de simplificar isso??

Agradeço desde já!

Att.,

 
Postado : 30/04/2012 6:32 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa noite!!

Veja isso...

Font: http://www.mrexcel.com/forum/showthread.php?t=288381
Autor:Jaafar Tribak

Coloque esse código no Formulário

Option Explicit

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 BitBlt Lib "gdi32" _
(ByVal hDestDC 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 dwRop As Long) As Long

Private Const SRCCOPY = &HCC0020

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

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

Private lfrmDC As Long

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type POINTAPI
    Width As Long
    Height As Long
End Type
'________________________________________________________________________
Private Declare Function CreateEllipticRgn Lib "gdi32" _
                          (ByVal X1 As Long, ByVal Y1 As Long, _
                           ByVal X2 As Long, ByVal Y2 As Long) As Long

 Private Declare Function SetWindowRgn Lib "user32" _
                          (ByVal hWnd As Long, ByVal hRgn As Long, _
                           ByVal bRedraw As Long) As Long
'_________________________________________________________________________
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long


Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Const GWL_STYLE = (-16)
Const WS_SYSMENU = &H80000
Private Const WS_CAPTION As Long = &HC00000

Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long
'_________________________________________________________________________

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private lfrmHwnd 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

Private Declare Sub ReleaseCapture Lib "user32" ()

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private objCmb As CommandBar



Private Sub UserForm_Initialize()
    Dim lBmp As Long
    Dim IPic As IPicture
    Dim Screen As POINTAPI
    
    'assign the form handle to a module level var
    'will be needed throughout the module
    lfrmHwnd = FindWindow(vbNullString, Me.Caption)
    
    'setup the shape of our form so it looks
    'like a round magnifying glass
    Call FormSetUp(lfrmHwnd)
    
    'get the form dc on which the drawing will be made
    lfrmDC = GetDC(lfrmHwnd)
    
    'get the screen dimensions
    Screen = GetScreenDims
    
    'get a pointer of the screen bitmap
    lBmp = GetScrnBmpHandle(GetDC(0), 0, 0, Screen.Width, Screen.Height)
    
    'create a picture from the bitmap pointer
    Set IPic = GetBitmapPic(lBmp)
    
    'save bitmap to disk
    stdole.SavePicture IPic, (Environ("Temp")) & "Scr.Bmp"
    'set the form picture to display the bitmap
     Me.Picture = LoadPicture((Environ("Temp")) & "Scr.Bmp")
    
    'clean up
    Kill (Environ("Temp")) & "Scr.Bmp"

End Sub


Private Sub UserForm_Activate()

    'the layout event doesn't fire here so refresh form now
    Me.Repaint
   Call UserForm_Layout
   
End Sub


Private Sub UserForm_Layout()

'update the userform background upon moving it
    StretchBlt _
     lfrmDC, 0, 0, Me.Width * 1.5, Me.Height * 1.5, _
     lMemoryDC, Me.Left * 1.5, Me.Top * 1.5, _
     Me.Width, Me.Height, SRCCOPY

End Sub

Private Sub UserForm_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)

    'show close menu
    If Button = 2 Then objCmb.ShowPopup

End Sub

Private Sub UserForm_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)

    'move the captionless form with the mouse
     If Button = 1 Then
        Call ReleaseCapture
        SendMessage lfrmHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
    End If

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    'safety cleanup
    On Error Resume Next
    DeleteDC lMemoryDC
    CommandBars("GlassPopUp").Delete

End Sub

'*** Supporting functions *******************************


Private Function GetScrnBmpHandle _
(lScrDC As Long, lScrnLeft As Long, lScrnTop As Long, _
lScrnWidth As Long, lScrnHeight As Long) As Long

    Dim lBmp, lOldBmp As Long
    
    'create a temp memory dc on which to copy the current screen shot
    lMemoryDC = CreateCompatibleDC(lScrDC)
    
    'create a bmp
    lBmp = CreateCompatibleBitmap(lScrDC, lScrnWidth, lScrnHeight)
    
    'select the bmp onto the temp dc
    lOldBmp = SelectObject(lMemoryDC, lBmp)
    DeleteObject lBmp
    
    'copy the screen image onto the temp dc
    BitBlt lMemoryDC, 0, 0, lScrnWidth, lScrnHeight, _
    lScrDC, lScrnLeft, lScrnTop, SRCCOPY
    
    'return our bmp pointer
    GetScrnBmpHandle = lBmp

End Function

Private Function GetBitmapPic(ByVal lBmpHandle As Long) As IPicture

Dim r As Long, IPic As IPicture, IID_IDispatch As GUID, Pic As uPicDesc

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    
    'Fill picture info
    With Pic
        .Size = Len(Pic) ' Length of structure
        .Type = 1  ' Type of Picture (bitmap)
        .hPic = lBmpHandle ' Handle to bitmap
        .hPal = 0 ' Handle to palette (may be null)
    End With
    'create the pic
    OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
    Set GetBitmapPic = IPic


End Function


Private Function GetScreenDims() As POINTAPI

    'get screen width an height
    Dim r As POINTAPI
    
    With r
        .Width = GetSystemMetrics(SM_CXSCREEN)
        .Height = GetSystemMetrics(SM_CYSCREEN)
    End With
    GetScreenDims = r

End Function


Private Sub FormSetUp(lhwnd As Long)

    Dim lHr, IStyle As Long
    
    'adjust form dims
    Me.Width = 210
    Me.Height = 195
    
    'Create rightclick close menu
    On Error Resume Next
    CommandBars("GlassPopUp").Delete
    Set objCmb = Application.CommandBars.Add(Position:=msoBarPopup)
    With objCmb
        objCmb.Name = "GlassPopUp"
        With .Controls.Add(msoControlButton)
            .Caption = "CloseMe"
            .OnAction = "CloseGlass"
        End With
    End With
    On Error GoTo 0
    'set the mouse pointer so it simulates
    'that of a magnifying glass
    
    Me.MousePointer = fmMousePointerCross
    'make the userform captionless and round
    'so it simulates a magnifying glass
    
    IStyle = GetWindowLong(lhwnd, GWL_STYLE)
    IStyle = IStyle And Not WS_CAPTION 'And WS_THICKFRAME
    SetWindowLong lhwnd, GWL_STYLE, IStyle
    DrawMenuBar lhwnd
    lHr = CreateEllipticRgn(0, 0, Me.Width, Me.Height)
    SetWindowRgn lhwnd, lHr, True

End Sub

Esse código em modulo

Option Explicit

Public lMemoryDC As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Sub CloseGlass()

    On Error Resume Next
    DeleteDC lMemoryDC
    CommandBars("GlassPopUp").Delete
    Unload UserForm1

End Sub

Sub Bouton1_QuandClic()

    UserForm1.Show

End Sub

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 30/04/2012 6:00 pm
 Robert
(@robert)
Posts: 561
Honorable Member
 

Boa noite, Geovania!

Para poder ver o que está na planilha de uma forma maior é simples. Com a planilha ativa click em CTRL depos role o botão Scrol do mouse ela ficara do jeito que desejar.

Abraços,

Att,
Robert / Moderador

Leia aqui as regras do fórum - Click -->> http://www.planilhando.com.br/forum/viewforum.php?f=7

SE A RESPOSTA FOI ÚTIL, AGRADEÇA CLICANDO NA MÃOZINHA LADO SUPERIOR DIREITO.

 
Postado : 30/04/2012 6:20 pm
 giovaniazoni
(@giovaniazoni)
Posts: 23
Eminent Member
Topic starter
 

Boa noite!!

Veja isso...

Font: http://www.mrexcel.com/forum/showthread.php?t=288381
Autor:Jaafar Tribak

Coloque esse código no Formulário

Option Explicit

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 BitBlt Lib "gdi32" _
(ByVal hDestDC 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 dwRop As Long) As Long

Private Const SRCCOPY = &HCC0020

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

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

Private lfrmDC As Long

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type POINTAPI
    Width As Long
    Height As Long
End Type
'________________________________________________________________________
Private Declare Function CreateEllipticRgn Lib "gdi32" _
                          (ByVal X1 As Long, ByVal Y1 As Long, _
                           ByVal X2 As Long, ByVal Y2 As Long) As Long

 Private Declare Function SetWindowRgn Lib "user32" _
                          (ByVal hWnd As Long, ByVal hRgn As Long, _
                           ByVal bRedraw As Long) As Long
'_________________________________________________________________________
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long


Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Const GWL_STYLE = (-16)
Const WS_SYSMENU = &H80000
Private Const WS_CAPTION As Long = &HC00000

Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long
'_________________________________________________________________________

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private lfrmHwnd 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

Private Declare Sub ReleaseCapture Lib "user32" ()

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private objCmb As CommandBar



Private Sub UserForm_Initialize()
    Dim lBmp As Long
    Dim IPic As IPicture
    Dim Screen As POINTAPI
    
    'assign the form handle to a module level var
    'will be needed throughout the module
    lfrmHwnd = FindWindow(vbNullString, Me.Caption)
    
    'setup the shape of our form so it looks
    'like a round magnifying glass
    Call FormSetUp(lfrmHwnd)
    
    'get the form dc on which the drawing will be made
    lfrmDC = GetDC(lfrmHwnd)
    
    'get the screen dimensions
    Screen = GetScreenDims
    
    'get a pointer of the screen bitmap
    lBmp = GetScrnBmpHandle(GetDC(0), 0, 0, Screen.Width, Screen.Height)
    
    'create a picture from the bitmap pointer
    Set IPic = GetBitmapPic(lBmp)
    
    'save bitmap to disk
    stdole.SavePicture IPic, (Environ("Temp")) & "Scr.Bmp"
    'set the form picture to display the bitmap
     Me.Picture = LoadPicture((Environ("Temp")) & "Scr.Bmp")
    
    'clean up
    Kill (Environ("Temp")) & "Scr.Bmp"

End Sub


Private Sub UserForm_Activate()

    'the layout event doesn't fire here so refresh form now
    Me.Repaint
   Call UserForm_Layout
   
End Sub


Private Sub UserForm_Layout()

'update the userform background upon moving it
    StretchBlt _
     lfrmDC, 0, 0, Me.Width * 1.5, Me.Height * 1.5, _
     lMemoryDC, Me.Left * 1.5, Me.Top * 1.5, _
     Me.Width, Me.Height, SRCCOPY

End Sub

Private Sub UserForm_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)

    'show close menu
    If Button = 2 Then objCmb.ShowPopup

End Sub

Private Sub UserForm_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)

    'move the captionless form with the mouse
     If Button = 1 Then
        Call ReleaseCapture
        SendMessage lfrmHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
    End If

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    'safety cleanup
    On Error Resume Next
    DeleteDC lMemoryDC
    CommandBars("GlassPopUp").Delete

End Sub

'*** Supporting functions *******************************


Private Function GetScrnBmpHandle _
(lScrDC As Long, lScrnLeft As Long, lScrnTop As Long, _
lScrnWidth As Long, lScrnHeight As Long) As Long

    Dim lBmp, lOldBmp As Long
    
    'create a temp memory dc on which to copy the current screen shot
    lMemoryDC = CreateCompatibleDC(lScrDC)
    
    'create a bmp
    lBmp = CreateCompatibleBitmap(lScrDC, lScrnWidth, lScrnHeight)
    
    'select the bmp onto the temp dc
    lOldBmp = SelectObject(lMemoryDC, lBmp)
    DeleteObject lBmp
    
    'copy the screen image onto the temp dc
    BitBlt lMemoryDC, 0, 0, lScrnWidth, lScrnHeight, _
    lScrDC, lScrnLeft, lScrnTop, SRCCOPY
    
    'return our bmp pointer
    GetScrnBmpHandle = lBmp

End Function

Private Function GetBitmapPic(ByVal lBmpHandle As Long) As IPicture

Dim r As Long, IPic As IPicture, IID_IDispatch As GUID, Pic As uPicDesc

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    
    'Fill picture info
    With Pic
        .Size = Len(Pic) ' Length of structure
        .Type = 1  ' Type of Picture (bitmap)
        .hPic = lBmpHandle ' Handle to bitmap
        .hPal = 0 ' Handle to palette (may be null)
    End With
    'create the pic
    OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
    Set GetBitmapPic = IPic


End Function


Private Function GetScreenDims() As POINTAPI

    'get screen width an height
    Dim r As POINTAPI
    
    With r
        .Width = GetSystemMetrics(SM_CXSCREEN)
        .Height = GetSystemMetrics(SM_CYSCREEN)
    End With
    GetScreenDims = r

End Function


Private Sub FormSetUp(lhwnd As Long)

    Dim lHr, IStyle As Long
    
    'adjust form dims
    Me.Width = 210
    Me.Height = 195
    
    'Create rightclick close menu
    On Error Resume Next
    CommandBars("GlassPopUp").Delete
    Set objCmb = Application.CommandBars.Add(Position:=msoBarPopup)
    With objCmb
        objCmb.Name = "GlassPopUp"
        With .Controls.Add(msoControlButton)
            .Caption = "CloseMe"
            .OnAction = "CloseGlass"
        End With
    End With
    On Error GoTo 0
    'set the mouse pointer so it simulates
    'that of a magnifying glass
    
    Me.MousePointer = fmMousePointerCross
    'make the userform captionless and round
    'so it simulates a magnifying glass
    
    IStyle = GetWindowLong(lhwnd, GWL_STYLE)
    IStyle = IStyle And Not WS_CAPTION 'And WS_THICKFRAME
    SetWindowLong lhwnd, GWL_STYLE, IStyle
    DrawMenuBar lhwnd
    lHr = CreateEllipticRgn(0, 0, Me.Width, Me.Height)
    SetWindowRgn lhwnd, lHr, True

End Sub

Esse código em modulo

Option Explicit

Public lMemoryDC As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Sub CloseGlass()

    On Error Resume Next
    DeleteDC lMemoryDC
    CommandBars("GlassPopUp").Delete
    Unload UserForm1

End Sub

Sub Bouton1_QuandClic()

    UserForm1.Show

End Sub

Nossa, em relação ao visual basics eu sou um palerma, rs..

poderia me mostrar como inserir esse código corretamente?

Muito Obrigado!

 
Postado : 02/05/2012 6:09 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia!!

Onde está escrito "Coloque esse código no Formulário"

Faça assim copie esse código, aperte as teclas Alt + F11 depois aperte, Alt + I + U, depois dê dois click's no Formulário e cole o código.

Onde está escrito "Esse código em modulo"
Faça assim copie esse código, aperte as teclas Alt + F11 depois aperte, Alt + I + M, cole o código.

Outra opção vá até o link e faça o DownLoad

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 02/05/2012 6:14 am
 giovaniazoni
(@giovaniazoni)
Posts: 23
Eminent Member
Topic starter
 

Bom dia!!

Onde está escrito "Coloque esse código no Formulário"

Faça assim copie esse código, aperte as teclas Alt + F11 depois aperte, Alt + I + U, depois dê dois click's no Formulário e cole o código.

Onde está escrito "Esse código em modulo"
Faça assim copie esse código, aperte as teclas Alt + F11 depois aperte, Alt + I + M, cole o código.

Outra opção vá até o link e faça o DownLoad

Bom dia!!

Nossa, esta dando erro em algo ou eu sou muito palerma mesmo.
Olha o erro que esta aparecendo:

Grato pela atenção!

 
Postado : 02/05/2012 6:34 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa tarde!!

O modo como os dados estão dentro do Formulário.

Faça o DownLoad no link da minha primeira postagem!!

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 02/05/2012 11:34 am
Forum Jump:
  Tópico Anterior
Próximo Tópico