none
Auto Update em VB 6 RRS feed

  • Pergunta

  • Boa tarde,

     

    Estou criando um programa com auto update, porém acontece 2 erros. 1º Ou todos os arquivos ficam com o conteudo em branco ou ele escreve o que está no arquivo "Atualizacoes.txt".

    Poderiam por favor me ajudar, pois ele chega e aparece ate baixando os arquivos, mais somente baixa ou em branco ou o conteudo do "Atualizacoes.txt".

    Estou tentando fazer um usando o VB6, ja que em VB.NET não encontrei ainda. abaixo segue o codigo que estou utilizando:

     

    FORMULARIO MAIN

    Dim IP, Site As String
    Dim Porta() As String

    Option Explicit

    'Declarações
    Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

    'IMPORTANTE !!! ENDEREÇO DO ARQUIVO DE INFORMAÇÃO DO UPDATE
    Private Const sEndereço As String = "http://l2sp.no-ip.org:8090/update/"
    'IMPORTANTE !!! ENDEREÇO DO ARQUIVO DE INFORMAÇÃO DO UPDATE

    'Verificação de Noticias ou Extração de Arquivos .RAR
    Private Const Noticias As Boolean = False
    Private Const ArquivosRAR As Boolean = False
    Private Const DeletarRAR As Boolean = False

    Private Type tAtualização
    sArquivo As String
    sData_Arquivo As String
    sData_Atualização As String
    sEndereço As String
    End Type

    Private sTamanho_do_Arquivo As String
    Private uInformaçao() As tAtualização

    Private Sub cmdCancelar_Click()
    End
    End Sub

    Private Sub Form_Initialize()
    InitCommonControls
    End Sub

    Private Sub Form_Load()

    'If Noticias = False Then
    'txtPrincipal.Visible = False
    'lblAtualização.Top = 100
    'ProgressBar1.Top = 590
    'ProgressBar2.Top = 350
    'cmdPronto.Top = 1000
    'cmdCancelar.Top = 1000
    'Me.Height = 2000
    'End If

    Site = "http://l2sp.no-ip.org:8090/"
    IP = "l2sp.no-ip.org"
    Porta() = Split("44405;55901", ";")
    Call Winsock1.Connect(IP, Porta(1))
    WebBrowser1.Navigate2 (Site)


    'Mudando a Cor da ProgreessBar1
    Call ProgressBar_ForeColor(ProgressBar1.hwnd, "006200")
    'Mudando a Cor da ProgreessBar2
    Call ProgressBar_ForeColor(ProgressBar2.hwnd, "255EFF")

    'Desativa o Botão cmdPronto
    'cmdPronto.Enabled = False
    'Verifica de a Pasta update existe
    Me.Show
    'Inicia o Update
    ComeçarAtualização
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    'Ao fechar o Programa, o download sendo feito pelo Inet e cancelado assim previnindo de erros ou problemas.
    iNet.Cancel
    End Sub

    Private Sub txtPrincipal_GotFocus()
    cmdCancelar.SetFocus
    End Sub
    Public Sub ComeçarAtualização()
    On Error Resume Next
    'Declarações do Codigo
    Dim iCnt As Integer
    Dim sAtualização As String
    Dim sNoticias As String
    Dim sSplit_a() As String, sSplit_b() As String
    Dim bByte_Atualização() As Byte
    Dim iInt As Integer
    Dim iArquivo As Integer
    Dim iBinary As Integer
    Dim sTemp As String
    Dim lTamanho As Long, lRestante As Long, lTamanhoAgora As Long
    Dim bChunk() As Byte
    Dim iProgresso As Integer
    Dim sPastas() As String
    Dim iMax As Integer
    Dim sAtualizacaoINI As String
    Dim sNoticiasINI As String
    Dim sPastasINI As String
    Dim lRar As Long
    Dim iMaxUP As Integer
    Dim iUpdates As Long
    'Fim das declarações


    sAtualização = iNet.OpenURL(sEndereço & "Informacoes.ini", icString) 'Baixando arquivo das informações do update
    'Escrevendo o arquivo de verificação dos arquivos de update
    Open App.Path & "\Informacoes.ini" For Append As #1
    Print #1, sAtualização
    Close #1

    lblAtualização.Caption = "Checando Atualizaçoes..."

    'Inserindo dados nas strings
    sAtualizacaoINI = ReadINI(App.Path & "\Informacoes.ini", "Informacoes", "Atualizacao")
    If Noticias Then
    sNoticiasINI = ReadINI(App.Path & "\Informacoes.ini", "Informacoes", "Noticias")
    End If
    sPastasINI = ReadINI(App.Path & "\Informacoes.ini", "Informacoes", "Pastas")
    Kill App.Path & "\Informacoes.ini"

    'Baixando arquivo de atualização e Noticias

    sAtualização = iNet.OpenURL(sEndereço & sAtualizacaoINI, icString)

    'Verificação de Status (OBS: Pode não funcionar..)
    If Len(sAtualização) <= 0 Then
    MsgBox "Ocorreu um erro na atualização, o servidor pode estar offline, contate o administrador.", vbCritical, "Error !"
    End
    End If

    'If Noticias Then
    'sNoticias = iNet.OpenURL(sEndereço & sNoticiasINI, icString)
    'txtPrincipal.Text = sNoticias
    'End If

    sSplit_a = Split(sAtualização, vbCrLf)

    ReDim uInformaçao(UBound(sSplit_a)) 'Re-declarando uInformação

    'Selecionando Informações dos arquivos a serem baixados
    For iCnt = LBound(sSplit_a) To UBound(sSplit_a)
    sSplit_b = Split(sSplit_a(iCnt), ", ")
    With uInformaçao(iCnt)
    .sArquivo = Trim$(sSplit_b(0))
    .sData_Atualização = Trim$(sSplit_b(1))
    .sEndereço = Trim$(sSplit_b(2))
    End With
    Next iCnt
    'Fim da seleção

    For iMaxUP = LBound(sSplit_a) To UBound(sSplit_a)
    If VerificarAtualizaçao(uInformaçao(iMaxUP).sArquivo, uInformaçao(iMaxUP).sData_Atualização) = False Then
    iUpdates = iUpdates + 1
    End If
    Next iMaxUP

    If Not iUpdates <= 0 Then
    ProgressBar2.Max = iUpdates
    End If

    'Essa parte vai verificar as pastas, baixar o arquivo, muda a porcetagem do arquivo ja baixado.
    For iCnt = 0 To UBound(uInformaçao)
    'Verifica se o arquivo ja foi baixado
    If Not VerificarAtualizaçao(uInformaçao(iCnt).sArquivo, uInformaçao(iCnt).sData_Atualização) Then
    'Coloca informações na Label
    lblAtualização.Caption = "Baixando " & uInformaçao(iCnt).sArquivo & ", Aguarde..."
    'Verifica as pastas a serem criadas
    sPastas() = Split(sPastasINI, "|")
    For iMax = LBound(sPastas) To UBound(sPastas)
    VerificarPasta (sPastas(iMax))
    Next
    DoEvents
    'Seleciona o arquivo a ser baixado pelo Inet
    bByte_Atualização() = iNet.OpenURL(uInformaçao(iCnt).sEndereço, icByteArray)
    'Verifica se o Inet esta Executando
    Do While iNet.StillExecuting = True
    DoEvents
    Loop
    'Muda o maximo da progressbar para 100
    ProgressBar1.Max = 100
    'Pega o Tamanho do Arquivo e muda os porcentos da progress bar e do Caption do Form
    lTamanho = CLng(iNet.GetHeader("Content-Length"))
    lRestante = lTamanho
    lTamanhoAgora = 0
    Do Until lRestante = 0
    If lRestante > 1024 Then
    bChunk = iNet.GetChunk(1024, icByteArray)
    lRestante = lRestante - 1024
    Else
    bChunk = iNet.GetChunk(lRestante, icByteArray)
    lRestante = 0
    End If
    lTamanhoAgora = lTamanho - lRestante
    iProgresso = CInt((100 / lTamanho) * lTamanhoAgora)
    ProgressBar1.Value = iProgresso
    lblAtualização.Caption = iProgresso & "%" & " Baixado" & " - Auto Update - "
    Loop
    'Escreve o arquivo baixado
    iBinary = FreeFile
    If VerificarArquivo(App.Path & "\" & uInformaçao(iCnt).sArquivo) Then
    Kill App.Path & "\" & uInformaçao(iCnt).sArquivo
    End If
    Open App.Path & "\" & uInformaçao(iCnt).sArquivo For Binary Access Write As #iBinary
    Put #iBinary, , bByte_Atualização()
    Close #iBinary
    'Escreve no arquivo de update
    iArquivo = FreeFile
    Open App.Path & sArquivoUPD For Append As iArquivo
    If Not uInformaçao(iCnt).sArquivo = "" Then
    Print #iArquivo, uInformaçao(iCnt).sArquivo & "|" & uInformaçao(iCnt).sData_Atualização
    End If
    Close #iArquivo
    End If

    If ProgressBar2.Value < ProgressBar2.Max Then
    ProgressBar2.Value = ProgressBar2.Value + 1
    End If


    'Verificando se a extração dos arquivos rar esta ativado.
    'If ArquivosRAR And VerificarRAR(uInformaçao(iCnt).sArquivo) Then
    'Abrindo arquivo RAR
    'Call rar.open(App.Path & "\" & uInformaçao(iCnt).sArquivo)
    'Extraindo arquivo RAR
    'lRar = rar.Unrar(App.Path & "\")
    'lblAtualização = "Extraindo Arquivo " & uInformaçao(iCnt).sArquivo
    'Se ocorrer tudo bem na extração do rar mostra uma mensagem.
    'If lRar <> 0 Then
    'lblAtualização = "Arquivo extraido com sucesso."
    'Se o DeletarRAR estiver TRUE, o rar instalado será deletado.
    'If DeletarRAR Then
    'Kill App.Path & "\" & uInformaçao(iCnt).sArquivo
    'End If

    'End If
    'End If
    Next iCnt

    'Informação ao Completar a Atualização
    If iNet.StillExecuting = False Then
    lblAtualização.Caption = "Finalizado..."
    ProgressBar1.Value = ProgressBar1.Max
    ProgressBar2.Value = ProgressBar2.Max
    End If
    'AutoUpdate.Caption = "Auto Update"
    Command1.Enabled = True
    Command2.Enabled = True
    cmdCancelar.Enabled = False
    End Sub

    Private Sub Command1_Click()
    Call Shell(App.Path & "\system\l2.exe")
    Unload Me
    End Sub

    Private Sub Command2_Click()
    Unload Me
    End Sub

    Private Sub Winsock1_Connect()
    'Label2.Caption = "Online!"
    'Label2.ForeColor = &HFF00&
    Winsock1.Close
    End Sub

    Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    'Label2.Caption = "Offline!"
    'Label2.ForeColor = &HFF&
    Winsock1.Close
    End Sub

    ----------------------------------------------------------------------------------------------------------------------------------------

    MODULO 1

     

    Option Explicit
    Public Const sArquivoUPD As String = "\Updates.upd"
    Public Const HKEY_CLASSES_ROOT = &H80000000
    Public Const HKEY_CURRENT_USER = &H80000001
    Public Const HKEY_LOCAL_MACHINE = &H80000002
    Public Const HKEY_USERS = &H80000003
    Public Const HKEY_PERFORMANCE_DATA = &H80000004
    Public Const HKEY_CURRENT_CONFIG = &H80000005
    Public Const HKEY_DYN_DATA = &H80000006
    Public Const REG_SZ = 1
    Public Const REG_BINARY = 3
    Public Const REG_DWORD = 4
    Public Const ERROR_SUCCESS = 0&
    Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
    Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
    Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
    Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
    Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
    Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long


    Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
    Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
    Public Ret As String

    Public Function VerificarArquivo(Arquivo As String) As Boolean
    If Len(Dir$(Arquivo, vbNormal)) > 0 Then
    VerificarArquivo = True
    Exit Function
    Else
    VerificarArquivo = False
    Exit Function
    End If
    End Function

    Public Function VerificarPasta(Pasta As String)
    If Len(Dir$(Pasta, vbDirectory)) > 0 Then
    Else
    MkDir App.Path & "\" & Pasta
    End If
    End Function

    'Função modificada para verificar arquivos rar com a extenção diferente como: Rar, RAr, rAr...
    Public Function VerificarRAR(sArquivo As String)
    If Right(sArquivo, 3) Like "[r-rR-R][a-aA-A][r-rR-R]" Then
    VerificarRAR = True
    Else
    VerificarRAR = False
    End If
    End Function

    'Função modificada, agora funcionando 100%
    Public Function VerificarAtualizaçao(sNome As String, sData As String) As Boolean
    Dim sLinhas() As String
    Dim sResultado() As String
    Dim sArquivo As String
    Dim i As Integer

    VerificarAtualizaçao = False

    Open App.Path & sArquivoUPD For Input As #1
    sArquivo = Input(LOF(1), #1)
    Close #1

    sLinhas() = Split(sArquivo, vbCrLf)
    For i = LBound(sLinhas) To UBound(sLinhas)
    sResultado() = Split(sLinhas(i), "|")
    If sNome = sResultado(0) And sData = sResultado(1) Then
    VerificarAtualizaçao = True
    Exit Function
    End If
    Next
    End Function

    Public Sub WriteINI(filename As String, Section As String, Key As String, Text As String)
    WritePrivateProfileString Section, Key, Text, filename
    End Sub
    Public Function ReadINI(filename As String, Section As String, Key As String)
    Dim RetLen As String
    Ret = Space$(255)
    RetLen = GetPrivateProfileString(Section, Key, "", Ret, Len(Ret), filename)
    Ret = Left$(Ret, RetLen)
    ReadINI = Ret
    End Function

    Public Sub CreateKey(hKey As Long, strPath As String)
    Dim hCurKey As Long
    Dim lRegResult As Long

    lRegResult = RegCreateKey(hKey, strPath, hCurKey)

    If lRegResult <> ERROR_SUCCESS Then

    End If

    lRegResult = RegCloseKey(hCurKey)

    End Sub

    Public Sub DeleteKey(ByVal hKey As Long, ByVal strPath As String)
    Dim lRegResult As Long

    lRegResult = RegDeleteKey(hKey, strPath)

    End Sub

    Public Sub DeleteValue(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String)
    Dim hCurKey As Long
    Dim lRegResult As Long

    lRegResult = RegOpenKey(hKey, strPath, hCurKey)

    lRegResult = RegDeleteValue(hCurKey, strValue)

    lRegResult = RegCloseKey(hCurKey)

    End Sub

    Public Function GetSettingString(hKey As Long, strPath As String, strValue As String, Optional Default As String) As String
    Dim hCurKey As Long
    Dim lValueType As Long
    Dim strBuffer As String
    Dim lDataBufferSize As Long
    Dim intZeroPos As Integer
    Dim lRegResult As Long

    If Not IsEmpty(Default) Then
    GetSettingString = Default
    Else
    GetSettingString = ""
    End If

    lRegResult = RegOpenKey(hKey, strPath, hCurKey)
    lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, ByVal 0&, lDataBufferSize)

    If lRegResult = ERROR_SUCCESS Then

    If lValueType = REG_SZ Then
    strBuffer = String(lDataBufferSize, " ")
    lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, ByVal strBuffer, lDataBufferSize)

    intZeroPos = InStr(strBuffer, Chr$(0))
    If intZeroPos > 0 Then
    GetSettingString = Left$(strBuffer, intZeroPos - 1)
    Else
    GetSettingString = strBuffer
    End If

    End If

    Else
    End If

    lRegResult = RegCloseKey(hCurKey)
    End Function

    Public Sub SaveSettingString(hKey As Long, strPath As String, strValue As String, strData As String)
    Dim hCurKey As Long
    Dim lRegResult As Long

    lRegResult = RegCreateKey(hKey, strPath, hCurKey)

    lRegResult = RegSetValueEx(hCurKey, strValue, 0, REG_SZ, ByVal strData, Len(strData))

    If lRegResult <> ERROR_SUCCESS Then
    End If

    lRegResult = RegCloseKey(hCurKey)
    End Sub

    Public Function GetSettingLong(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, Optional Default As Long) As Long

    Dim lRegResult As Long
    Dim lValueType As Long
    Dim lBuffer As Long
    Dim lDataBufferSize As Long
    Dim hCurKey As Long

    If Not IsEmpty(Default) Then
    GetSettingLong = Default
    Else
    GetSettingLong = 0
    End If

    lRegResult = RegOpenKey(hKey, strPath, hCurKey)
    lDataBufferSize = 4

    lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, lBuffer, lDataBufferSize)

    If lRegResult = ERROR_SUCCESS Then

    If lValueType = REG_DWORD Then
    GetSettingLong = lBuffer
    End If

    Else
    End If

    lRegResult = RegCloseKey(hCurKey)

    End Function

    Public Sub SaveSettingLong(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, ByVal lData As Long)
    Dim hCurKey As Long
    Dim lRegResult As Long

    lRegResult = RegCreateKey(hKey, strPath, hCurKey)

    lRegResult = RegSetValueEx(hCurKey, strValue, 0&, REG_DWORD, lData, 4)

    If lRegResult <> ERROR_SUCCESS Then
    End If

    lRegResult = RegCloseKey(hCurKey)
    End Sub

    Public Function GetSettingByte(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, Optional Default As Variant) As Variant
    Dim lValueType As Long
    Dim byBuffer() As Byte
    Dim lDataBufferSize As Long
    Dim lRegResult As Long
    Dim hCurKey As Long

    If Not IsEmpty(Default) Then
    If VarType(Default) = vbArray + vbByte Then
    GetSettingByte = Default
    Else
    GetSettingByte = 0
    End If

    Else
    GetSettingByte = 0
    End If

    lRegResult = RegOpenKey(hKey, strPath, hCurKey)
    lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufferSize)

    If lRegResult = ERROR_SUCCESS Then

    If lValueType = REG_BINARY Then

    ReDim byBuffer(lDataBufferSize - 1) As Byte
    lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, byBuffer(0), lDataBufferSize)

    GetSettingByte = byBuffer

    End If

    Else
    End If

    lRegResult = RegCloseKey(hCurKey)

    End Function

    Public Sub SaveSettingByte(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, byData() As Byte)

    Dim lRegResult As Long
    Dim hCurKey As Long

    lRegResult = RegCreateKey(hKey, strPath, hCurKey)

    lRegResult = RegSetValueEx(hCurKey, strValueName, 0&, REG_BINARY, byData(0), UBound(byData()) + 1)

    lRegResult = RegCloseKey(hCurKey)

    End Sub

    Public Function GetAllKeys(hKey As Long, strPath As String) As Variant

    Dim lRegResult As Long
    Dim lCounter As Long
    Dim hCurKey As Long
    Dim strBuffer As String
    Dim lDataBufferSize As Long
    Dim strNames() As String
    Dim intZeroPos As Integer

    lCounter = 0

    lRegResult = RegOpenKey(hKey, strPath, hCurKey)

    Do

    lDataBufferSize = 255
    strBuffer = String(lDataBufferSize, " ")
    lRegResult = RegEnumKey(hCurKey, lCounter, strBuffer, lDataBufferSize)

    If lRegResult = ERROR_SUCCESS Then

    ReDim Preserve strNames(lCounter) As String

    intZeroPos = InStr(strBuffer, Chr$(0))
    If intZeroPos > 0 Then
    strNames(UBound(strNames)) = Left$(strBuffer, intZeroPos - 1)
    Else
    strNames(UBound(strNames)) = strBuffer
    End If

    lCounter = lCounter + 1

    Else
    Exit Do
    End If
    Loop

    GetAllKeys = strNames
    End Function

    Public Function GetAllValues(hKey As Long, strPath As String) As Variant

    Dim lRegResult As Long
    Dim hCurKey As Long
    Dim lValueNameSize As Long
    Dim strValueName As String
    Dim lCounter As Long
    Dim byDataBuffer(4000) As Byte
    Dim lDataBufferSize As Long
    Dim lValueType As Long
    Dim strNames() As String
    Dim lTypes() As Long
    Dim intZeroPos As Integer

    lRegResult = RegOpenKey(hKey, strPath, hCurKey)

    Do
    lValueNameSize = 255
    strValueName = String$(lValueNameSize, " ")
    lDataBufferSize = 4000

    lRegResult = RegEnumValue(hCurKey, lCounter, strValueName, lValueNameSize, 0&, lValueType, byDataBuffer(0), lDataBufferSize)

    If lRegResult = ERROR_SUCCESS Then

    ReDim Preserve strNames(lCounter) As String
    ReDim Preserve lTypes(lCounter) As Long
    lTypes(UBound(lTypes)) = lValueType

    intZeroPos = InStr(strValueName, Chr$(0))
    If intZeroPos > 0 Then
    strNames(UBound(strNames)) = Left$(strValueName, intZeroPos - 1)
    Else
    strNames(UBound(strNames)) = strValueName
    End If

    lCounter = lCounter + 1

    Else
    Exit Do
    End If
    Loop

    Dim Finisheddata() As Variant
    ReDim Finisheddata(UBound(strNames), 0 To 1) As Variant

    For lCounter = 0 To UBound(strNames)
    Finisheddata(lCounter, 0) = strNames(lCounter)
    Finisheddata(lCounter, 1) = lTypes(lCounter)
    Next

    GetAllValues = Finisheddata

    End Function

    -----------------------------------------------------------------------------------------------------------------------------------------

     

    MODULO 2

     

    Option Explicit

    Const WM_USER = &H400
    Const CCM_FIRST = &H2000&
    Const CCM_SETBKCOLOR = (CCM_FIRST + 1)
    Const PBM_SETBKCOLOR = CCM_SETBKCOLOR
    Const PBM_SETBARCOLOR = (WM_USER + 9)

    Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

    Public Function ProgressBar_ForeColor(ByVal hwnd As Long, ByVal sCor As String)
    SendMessage hwnd, PBM_SETBARCOLOR, 0, ByVal VBColor(sCor)
    End Function

    Public Function ProgressBar_Color(ByVal hwnd As Long, ByVal sCor As String)
    SendMessage hwnd, PBM_SETBKCOLOR, 0, ByVal VBColor(sCor)
    End Function

    Private Function VBColor(sCor As String) As Long
    If Len(sCor) < 6 Then
    sCor = sCor & String(6 - Len(sCor), "0")
    End If
    VBColor = "&H" & Mid(sCor, 5, 2) & Mid(sCor, 3, 2) & Mid(sCor, 1, 2)
    End Function

     

    Desde ja agradeço.

    domingo, 21 de março de 2010 19:48

Respostas

Todas as Respostas