Ir para conteúdo
Fórum Script Brasil

ramon

Membros
  • Total de itens

    1.354
  • Registro em

  • Última visita

Posts postados por ramon

  1. Vou usar apenas uma coluna pois a ideia é usar a listview para dicionar uma narração de jogo de futebol parecidada com a que tem na globo.com onde a ultima frase adicionada sempre fica no topo da listview e o restante vai descendo entendes?

    já tentei usar a propiedade sortOrder para lvwDescending mas porem ele ordena somente ate 9 posicoes apos isso ele não ordena pois acho que a decima posicao ele entenda como 1 ou sei la.

    alguém tem uma solução?

    Pensei em usar uma listbox que seria o ideal mas porem não tem como adiconar icones dentro de uma lisbox ae não me serve

  2. não seria bem isso que eu queria

    Tipo eu sei que eu substituir lá em nota 2 em vez de 5 eu colocar 5,6 eu vou ter media 6 correto

    então o que eu quero é descobrir quanto eu preciso lá no valor inicial de nota2 para que eu tenha uma media 6 entendeu?

  3. Tenho como obter a media ponderada de duas provas da seguinte forma

    nota1 = 7

    nota2 = 5

    peso1 = 33

    peso2 = 67

    mediaPonderada = (nota1 * peso1 + nota2 * peso2) / (peso1 + peso2)

    beleza

    se a mediaponderada ficar abaixo de 6 o aluno tem que fazer uma prova de recuperacao porem preciso informar ao aluno qual o minimo que ele tem que tirar na nota2 para que ele possa ter uma media ponderada 6

    Como fazer isso?

  4. Tenho como obter a media ponderada de duas provas da seguinte forma

    nota1 = 7

    nota2 = 5

    peso1 = 33

    peso2 = 67

    mediaPonderada = (nota1 * peso1 + nota2 * peso2) / (peso1 + peso2)

    beleza

    se a mediaponderada ficar abaixo de 6 o aluno tem que fazer uma prova de recuperacao porem preciso informar ao aluno qual o minimo que ele tem que tirar na nota2 para que ele possa ter uma media ponderada 6

    Como fazer isso?

  5. Quantos bytes ocupa uma matriz definida como string

    Como eu posso descobrir?

    dim matris(10,4,2) as string

    se fosse definido como byte dim matriz(10,4,2) as byte eu saberia definir já que bastava eu multiplicar (11*5*2)*1byte que é o espaço de armazenamento

    Mas e a string como eu posso descobrir já que posso ter varios caracteres de diversos tamanho dentro dela?

    existe alguma funçao?

  6. COmo eu faria para salvar uma estrutura que tem arrays? Eu teria que criar um laço ou tem outro jeito de salvar?

    exemplo

    Type Estrutura 
        Array1(3) As Integer 
        array2 As Byte 
    End Type 
    Public teste(10) As Estrutura 
    Private Sub Form_Load()
    teste(1).Array1(1) = 2
    teste(2).Array1(1) = 4
    teste(3).Array1(1) = 6
    
    End Sub
    Private Sub Command1_Click()
    Open App.Path & "\teste.txt" For Output As #1
    Print #1, teste
    
    Close #1
    
    End Sub

    só que da erro e eu naõ queria usar um laço

  7. Achei uma maneira aí vai

    Coloque um SStab no form

    coloque o codigo no form

    Private Sub Form_Load()
        'função para converter a cor do sstab
        SetStyle SSTab1.hWnd, cSolidColor
                                'este ultimo parametro é que define a cor
        SetSolidColor SSTab1.hWnd, &H40C0&
        SSTabSubclass SSTab1.hWnd
    End Sub
    Agora coloque o codigo abaixo num modulo
    Option Explicit
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    Private Type GRADIENT_RECT
        UPPERLEFT  As Long
        LOWERRIGHT As Long
    End Type
    Private Type TRIVERTEX
        X       As Long
        Y       As Long
        Red     As Integer
        Green   As Integer
        Blue    As Integer
        Alpha   As Integer
    End Type
    
    Private Type RGB
        R As Integer
        G As Integer
        B As Integer
    End Type
    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 Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
    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 CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
    Private Declare Function RedrawWindow Lib "user32" (ByVal hWnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc 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
    Private Declare Function ValidateRect Lib "user32" (ByVal hWnd As Long, ByVal lpRect As Long) As Long
    Private Const GWL_WNDPROC As Long = (-4)
    Private Const WM_PAINT    As Long = &HF
    Private Const WM_DESTROY  As Long = &H2
    Private Const WM_TIMER    As Long = &H113
    Private Const ID_TIMER    As Long = &HCBABE
    Public Enum TabStyle
           cSolidColor = 0
           cPicture = 1
           cGradient = 2
           cAnimatedGradient = 3
    End Enum
    Public Enum Direction
           cHorizontal = 0
           cVertical = 1
    End Enum
    Private DestDC      As Long
    Private MaskDC      As Long
    Private MemDC       As Long
    Private OrigDC      As Long
    Private MaskPic     As Long
    Private MemPic      As Long
    Private TempPic     As Long
    Private OrigPic     As Long
    Private TempDC      As Long
    Private origBrush As Long
    Private TempBrush As Long
    Private origColor As Long
    Private gColor1   As Long
    Private gColor2   As Long
    Private gDir      As Long
    Private gTime     As Long
    Private gFadeFlag As Boolean
    Private ImageWidth  As Long
    Private ImageHeight As Long
    Private oldWndProc As Long
    Private Function GetLngColor(Color As Long) As Long
        If (Color And &H80000000) Then
            GetLngColor = GetSysColor(Color And &H7FFFFFFF)
        Else
            GetLngColor = Color
        End If
    End Function
    Private Function GetRGBColors(Color As Long) As RGB
    Dim HexColor As String
        HexColor = String(6 - Len(Hex(Color)), "0") & Hex(Color)
        GetRGBColors.R = "&H" & Mid(HexColor, 5, 2) & "00"
        GetRGBColors.G = "&H" & Mid(HexColor, 3, 2) & "00"
        GetRGBColors.B = "&H" & Mid(HexColor, 1, 2) & "00"
    End Function
    Public Sub SetStyle(ByVal hWnd As Long, ByRef Style As TabStyle)
               SetProp hWnd, "MyStyle", Style
    End Sub
    Public Sub SetFadeTime(ByVal hWnd As Long, ByVal cTime As Long)
        If cTime > 10 Then cTime = 10
        If cTime < 1 Then cTime = 1
               SetProp hWnd, "MyFadeTime", cTime
    End Sub
    Private Function GetFadeTime(ByVal hWnd As Long) As Long
               GetFadeTime = GetProp(hWnd, "MyFadeTime")
    End Function
    Private Function GetStyleParams(ByVal hWnd As Long) As TabStyle
               GetStyleParams = GetProp(hWnd, "MyStyle")
    End Function
    Public Sub SetGradientDir(ByVal hWnd As Long, ByRef Style As Direction)
               SetProp hWnd, "MyGradientDir", Style
    End Sub
    Private Sub GetGradientDir(ByVal hWnd As Long)
               gDir = GetProp(hWnd, "MyGradientDir")
    End Sub
    Private Sub SetHookInstance(ByVal hWnd As Long)
               SetProp hWnd, "Hooked", True
    End Sub
    Private Function CheckHookInstance(ByVal hWnd As Long) As Boolean
               CheckHookInstance = GetProp(hWnd, "Hooked")
    End Function
    Public Sub SetSolidColor(ByVal hWnd As Long, ByVal Color As Long)
               SetProp hWnd, "MySolidColor", GetLngColor(Color)
    End Sub
    Public Sub SetGradientColor1(ByVal hWnd As Long, ByVal Color As Long)
               SetProp hWnd, "MyGradientColor1", GetLngColor(Color)
    End Sub
    Public Sub SetGradientColor2(ByVal hWnd As Long, ByVal Color As Long)
               SetProp hWnd, "MyGradientColor2", GetLngColor(Color)
    End Sub
    Private Sub GetSolidColor(ByVal hWnd As Long)
         TempBrush = CreateSolidBrush(GetProp(hWnd, "MySolidColor"))
    End Sub
    Private Sub GetGradientColor1(ByVal hWnd As Long)
         gColor1 = GetProp(hWnd, "MyGradientColor1")
    End Sub
    Private Sub GetGradientColor2(ByVal hWnd As Long)
         gColor2 = GetProp(hWnd, "MyGradientColor2")
    End Sub
    Public Sub SetPicture(ByVal hWnd As Long, ByVal Width As Long, ByVal Height As Long, ByRef cPicture As StdPicture)
               SetProp hWnd, "MyPicture", cPicture.Handle
               SetProp hWnd, "MyPictureWidth", Width
               SetProp hWnd, "MyPictureHeight", Height
    End Sub
    Private Sub GetPictureParams(ByVal hWnd As Long)
        TempBrush = CreatePatternBrush(GetProp(hWnd, "MyPicture"))
        ImageWidth = GetProp(hWnd, "MyPictureWidth")
        ImageHeight = GetProp(hWnd, "MyPictureHeight")
    End Sub
    Public Sub SSTabSubclass(ByVal hWnd As Long)
    If Not CheckHookInstance(hWnd) Then
        SetHookInstance hWnd
        oldWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf oldSSTabProc)
    End If
    End Sub
    Public Function oldSSTabProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
           If GetStyleParams(hWnd) = cAnimatedGradient Then
              KillTimer hWnd, 0
              SetTimer hWnd, ID_TIMER, 1, 0
           End If
           oldSSTabProc = NewSSTabProc(hWnd, uMsg, wParam, lParam)
    End Function
    Private Function NewSSTabProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
         On Error Resume Next
        Dim m_ItemRect As RECT
        Dim m_Width    As Long
        Dim m_Height   As Long
        If wMsg = WM_PAINT Then
            DestDC = GetDC(hWnd)
            GetWindowRect hWnd, m_ItemRect
                    m_Width = m_ItemRect.Right - m_ItemRect.Left
                    m_Height = m_ItemRect.Bottom - m_ItemRect.Top
            Select Case GetStyleParams(hWnd)
             Case cPicture
                  GetPictureParams hWnd
             Case cSolidColor
                  GetSolidColor hWnd
             Case cGradient
                  GetGradientColor1 hWnd
                  GetGradientColor2 hWnd
                  GetGradientDir hWnd
             Case cAnimatedGradient
                  GetGradientDir hWnd
             
             Case Else
                   Debug.Print "Invalid Style"
            End Select
            CreateNewDCWorkArea m_Width, m_Height
            Call SelectBitmap
            CallWindowProc oldWndProc, hWnd, wMsg, OrigDC, lParam
            Call CreateBackMask(m_Width, m_Height)
            origBrush = SelectObject(TempDC, TempBrush)
            If GetStyleParams(hWnd) = cGradient Or GetStyleParams(hWnd) = cAnimatedGradient Then
                DrawGradient TempDC, 0, 0, m_Width, m_Height, GetRGBColors(gColor1), GetRGBColors(gColor2), gDir
            Else
                PatBlt TempDC, 0, 0, m_Width, m_Height, vbPatCopy
            End If
            SelectObject TempDC, origBrush
            Call DOBitBlt(m_Width, m_Height)
            Call CleanDCs
            SetBkColor DestDC, origColor
            ReleaseDC hWnd, DestDC
            ValidateRect hWnd, 0
        ElseIf wMsg = WM_TIMER Then
            If GetStyleParams(hWnd) <> cAnimatedGradient Then
                KillTimer hWnd, 0
                Exit Function
            End If
            If gFadeFlag Then
                gTime = gTime - GetFadeTime(hWnd)
            Else
                gTime = gTime + GetFadeTime(hWnd)
            End If
            If gTime > 255 Then
               gTime = 255
               gFadeFlag = Not gFadeFlag
            ElseIf gTime < 0 Then
               gTime = 0
               gFadeFlag = Not gFadeFlag
            End If
            GetGradientColor1 hWnd
            GetGradientColor2 hWnd
            gColor1 = ShiftColor(gColor1, gTime)
            gColor2 = ShiftColor(gColor2, gTime)
            RedrawWindow hWnd, ByVal 0&, ByVal 0&, &H1
            Debug.Print gTime
        ElseIf wMsg = WM_DESTROY Then
            KillTimer hWnd, 0
            DeleteObject TempBrush
            SetWindowLong hWnd, GWL_WNDPROC, oldWndProc
            NewSSTabProc = CallWindowProc(oldWndProc, hWnd, wMsg, wParam, lParam)
        Else
            NewSSTabProc = CallWindowProc(oldWndProc, hWnd, wMsg, wParam, lParam)
        End If
    End Function
    Private Sub SelectBitmap()
    Dim cHandle As Long
           cHandle = SelectObject(MaskDC, MaskPic)
           DeleteObject cHandle
           cHandle = SelectObject(MemDC, MemPic)
           DeleteObject cHandle
           cHandle = SelectObject(TempDC, TempPic)
           DeleteObject cHandle
           cHandle = SelectObject(OrigDC, OrigPic)
           DeleteObject cHandle
    End Sub
    Private Sub CreateBackMask(ByVal m_Width As Long, ByVal m_Height As Long)
            origColor = SetBkColor(DestDC, GetSysColor(15))
            SetBkColor OrigDC, GetSysColor(15)
            BitBlt MaskDC, 0, 0, m_Width, m_Height, OrigDC, 0, 0, vbSrcCopy
    End Sub
    Private Sub CreateNewDCWorkArea(ByVal m_Width As Long, ByVal m_Height As Long)
            MaskDC = CreateCompatibleDC(DestDC)
            MaskPic = CreateBitmap(m_Width, m_Height, 1, 1, ByVal 0&)
            MemDC = CreateCompatibleDC(DestDC)
            MemPic = CreateCompatibleBitmap(DestDC, m_Width, m_Height)
            TempDC = CreateCompatibleDC(DestDC)
            TempPic = CreateCompatibleBitmap(DestDC, m_Width, m_Height)
            OrigDC = CreateCompatibleDC(DestDC)
            OrigPic = CreateCompatibleBitmap(DestDC, m_Width, m_Height)
    End Sub
    Private Sub DOBitBlt(ByVal m_Width As Long, ByVal m_Height As Long)
            BitBlt MemDC, 0, 0, m_Width, m_Height, MaskDC, 0, 0, vbSrcCopy
            BitBlt MemDC, 0, 0, m_Width, m_Height, OrigDC, 0, 0, vbSrcPaint
            BitBlt TempDC, 0, 0, m_Width, m_Height, MaskDC, 0, 0, vbMergePaint
            BitBlt TempDC, 0, 0, m_Width, m_Height, MemDC, 0, 0, vbSrcAnd
            BitBlt DestDC, 0, 0, m_Width, m_Height, TempDC, 0, 0, vbSrcCopy
    End Sub
    Private Sub CleanDCs()
            DeleteDC TempDC
            DeleteObject TempPic
            DeleteDC MaskDC
            DeleteObject MaskPic
            DeleteDC MemDC
            DeleteObject MemPic
            DeleteDC OrigDC
            DeleteObject OrigPic
            DeleteObject TempBrush
    End Sub
    Private Sub DrawGradient(cHdc As Long, X As Long, Y As Long, X2 As Long, Y2 As Long, Color1 As RGB, Color2 As RGB, Optional Direction = 1)
    Dim Vert(1) As TRIVERTEX
    Dim gRect As GRADIENT_RECT
        With Vert(0)
            .X = X
            .Y = Y
            .Red = Color1.R
            .Green = Color1.G
            .Blue = Color1.B
            .Alpha = 0&
        End With
        With Vert(1)
            .X = Vert(0).X + X2
            .Y = Vert(0).Y + Y2
            .Red = Color2.R
            .Green = Color2.G
            .Blue = Color2.B
            .Alpha = 0&
        End With
        gRect.UPPERLEFT = 0
        gRect.LOWERRIGHT = 1
        GradientFillRect cHdc, Vert(0), 2, gRect, 1, Direction
    End Sub
    Private Function ShiftColor(ByVal Color As Long, ByVal Value As Long) As Long
    Dim R As Long
    Dim G As Long
    Dim B As Long
          R = (Color And &HFF) + Value
          G = ((Color \ &H100) Mod &H100) + Value
          B = ((Color \ &H10000) Mod &H100)
          B = B + ((B * Value) \ &HC0)
        If Value > 0 Then
            If R > 255 Then R = 255
            If G > 255 Then G = 255
            If B > 255 Then B = 255
        ElseIf Value < 0 Then
            If R < 0 Then R = 0
            If G < 0 Then G = 0
            If B < 0 Then B = 0
        End If
        ShiftColor = R + 256& * G + 65536 * B
    End Function

    Feito agora você consegue mudar a cor do Sstab

    falou!

×
×
  • Criar Novo...