Tomás Vásquez Fórum

Boa noite Galera.
Bom... vou iniciar uma serie de dicas com imagens e detalhes de como tudo será realizado!
Iniciaremos pelo começo.
Acredito que, será bem legal a todos conhecer como tudo é feito. Baixem o modelo e tudo que será utilizado.
Para facilitar... o mesmo está compactado e é somente um modelo para que vocês possam já utilizar e ver tudo que será explicado ao longo de muitos dias... fiquem firmes... sempre que der... deixo uma dica nova e para aqueles que queiram as senhas de acesso... Entrem em contato!

Uma palhinha de tudo...
Na Tela de Login
Usuário = CLEUDIMAR
Senha = 212826
Brinquem a vontade!

Não se esqueçam... mantenham tudo na mesma pasta como está no anexo... a brincadeira vai começar!

1ª Dica... Códigos de Programação!
Não tenham medo de errar! Vão descobrir que, errando sempre aprendemos formas de como a lógica de programação é interpretada pelo leitor.
* Código do Splash:
Crie um formulário dentro do VBA e insira o código abaixo.

Option Explicit
 
Private Declare Function GetActiveWindow Lib "user32" () As Long
 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal lngWinIdx As Long, _
ByVal dwNewLong As Long) As Long
 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal lngWinIdx As Long) As Long
 
Private Declare Function SetLayeredWindowAttributes Lib "user32" _
(ByVal hWnd As Long, _
ByVal crKey As Integer, _
ByVal bAlpha As Integer, _
ByVal dwFlags As Long) As Long
 
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = &HFFEC
 
Dim hWnd            As Long
Dim Transparancy    As Integer
Dim Running         As Boolean


Private Sub UserForm_Activate()
     
    Running = True
    Call Transparency
     
End Sub
 
Private Sub Transparency()
     
    Dim MyTimer         As Double
     
    DoEvents
    MyTimer = Timer
    Do
        Do
        Loop While Timer - MyTimer < 0.04
        MyTimer = Timer
        Transparancy = Transparancy - 1
        If Transparancy < 0 Then
            Unload Me
        Else
            Call SemiTransparent(Application.WorksheetFunction.Min(Transparancy, 100))
        End If
        DoEvents
    Loop While Running
     
End Sub
 
Private Sub SemiTransparent(ByVal intLevel As Integer)
     
    Dim lngWinIdx       As Long
     
    hWnd = GetActiveWindow
    lngWinIdx = GetWindowLong(hWnd, GWL_EXSTYLE)
    SetWindowLong hWnd, GWL_EXSTYLE, lngWinIdx Or WS_EX_LAYERED
    SetLayeredWindowAttributes hWnd, 0, (255 * intLevel) / 100, LWA_ALPHA
     
End Sub

 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     
    Running = False

    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
    
    End Sub
Private Sub UserForm_Initialize()
    Transparancy = 120
    Call SemiTransparent(100)
    DoEvents
    
    
' Metodo Invisivel do Excel
Application.Visible = False

Application.OnTime Now + TimeValue("00:00:04"), "FechaForm"


End Sub

* Código para criar atalho:
Dentro do VBA, crie um modulo com o nome - Criar_Atalho.
Dentro do modulo, insira o código abaixo...

Sub CreateDesktopShortcut()
'   Msgbox string variables
    Dim szMsg As String
    Dim szStyle As String
    Dim szTitle As String
    
'   Change here for the icon's name
    Const szIconName As String = "/Sistema All Control.ico"
    
'   Constant string values, you can replace "Desktop"
'   with any Special Folders name to create the shortcut there
    Const szlocation As String = "Desktop"
    Const szLinkExt As String = ".lnk"

'   Object variables
    Dim oWsh As Object
    Dim oShortcut As Object
        
'   String variables
    Dim szSep As String
    Dim szBookName As String
    Dim szBookFullName As String
    Dim szPath As String
    Dim szDesktopPath As String
    Dim szShortcut As String
    
'   Initialize variables
    szSep = Application.PathSeparator
    szBookName = szSep & ThisWorkbook.Name
    szBookFullName = ThisWorkbook.FullName
    szPath = ThisWorkbook.Path

    On Error GoTo ErrHandle
'   The WScript.Shell object provides functions to read system
'   information and environment variables, work with the registry
'   and manage shortcuts
    Set oWsh = CreateObject("WScript.Shell")
    szDesktopPath = oWsh.SpecialFolders(szlocation)
        
'   Get the path where the shortcut will be located
    szShortcut = szDesktopPath & szBookName & szLinkExt
    
'   Make it happen
    Set oShortcut = oWsh.CreateShortCut(szShortcut)
    
'   Link it to this file
    With oShortcut

         .TargetPath = szBookFullName
        .IconLocation = szPath & szIconName
        .Save
    End With
    
'   Explicitly clear memory
    Set oWsh = Nothing
    Set oShortcut = Nothing
    
    Exit Sub
       
'   or if it wasn't
ErrHandle:
    szMsg = "Erro ao criar Icone no Desktop!"
    szStyle = 48
    szTitle = "Erro!"
    
    MsgBox szMsg, szStyle, szTitle
End Sub

* Para chamar todas as ações, dentro da Opção - Esta Pasta de Trabalho... Cole o código abaixo.

Private Sub Workbook_Activate()
Call Formatar_Tela_Menu
Call RetiraXdaBarra
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call Formatar_Tela_Normal
Call RepoeXdaBarra
End Sub

Private Sub Workbook_Deactivate()
Call Formatar_Tela_Normal
Call RepoeXdaBarra
End Sub

Private Sub Workbook_Open()

ActiveSheet.Unprotect

Call CreateDesktopShortcut
Call Formatar_Tela_Menu
Call RetiraXdaBarra

Worksheets(1).ScrollArea = "A1:U36"

Form_splash.Show
End Sub

Agora, vamos a uma parte bem legal que, fará sua aplicação ficar mais apresentada e bem bacana...
Vamos brincar um pouco com os Ribbons do Excel. Isso mesmo! Vamos brincar com esta parte!
* Crie um modulo com o nome de Ribbons e cole o código abaixo..

Declare Function FindWindow32 Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Integer
Declare Function GetWindowLong32 Lib "user32" Alias "GetWindowLongA" _
        (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
Declare Function SetWindowLong32 Lib "user32" Alias "SetWindowLongA" _
        (ByVal hWnd As Integer, ByVal nIndex As Integer, _
        ByVal dwNewLong As Long) As Long
        
Global Const GWL_STYLE = (-16)
Global Const WS_SYSMENU = &H80000


Sub Formatar_Tela_Menu()


With Application

'Desabilita eventos
.ScreenUpdating = False
.EnableEvents = False


'Ações de execução
.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"
.DisplayFormulaBar = False
.DisplayStatusBar = False
.Caption = "Sistema All Control"

'Ação das barras de GridLine do Excel
With ActiveWindow

.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = False
.DisplayHeadings = False
.DisplayGridlines = False

End With


'Habilita eventos
.ScreenUpdating = True
.EnableEvents = True


End With


End Sub

Sub Formatar_Tela_Normal()


With Application

'Desabilita eventos
.ScreenUpdating = False
.EnableEvents = False


'Ações de execução
.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",true)"
.DisplayFormulaBar = True
.DisplayStatusBar = True
.Caption = ""


'Ação das barras de GridLine do Excel
With ActiveWindow

.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = True
.DisplayHeadings = True
.DisplayGridlines = True

End With


'Habilita eventos
.ScreenUpdating = True
.EnableEvents = True


End With


End Sub
Sub RepoeXdaBarra()

    Application.ScreenUpdating = True
    Dim WindowStyle As Long
    Dim hWnd As Integer
    Dim WindowName As String
    Dim Result As Variant

    WindowName = Application.Caption
    hWnd = FindWindow32(0&, ByVal WindowName)
    WindowStyle = GetWindowLong32(hWnd, GWL_STYLE)
    WindowStyle = WindowStyle Or WS_SYSMENU
    Result = SetWindowLong32(hWnd, GWL_STYLE, WindowStyle)


End Sub

Sub RetiraXdaBarra()

Application.ScreenUpdating = False

    Dim WindowStyle As Long
    Dim hWnd As Integer
    Dim WindowName As String
    Dim Result As Variant

    WindowName = Application.Caption
    hWnd = FindWindow32(0&, ByVal WindowName)
    WindowStyle = GetWindowLong32(hWnd, GWL_STYLE)
    WindowStyle = WindowStyle And (Not WS_SYSMENU)
    Result = SetWindowLong32(hWnd, GWL_STYLE, WindowStyle)

    'Força a barra de títulos a se atualizar, Ocultando os Botões
    Application.Caption = "Sistemas Integrados (Copyright © 2016)"
    ActiveWindow.Caption = " Desenvolvido Por: XcellSolutions "

End Sub

Bom! Aqui finalizamos nossa 1ª Dica de como tudo é feito no modelo em anexo a este post!
Baixem o mesmo! Aproveitem a oportunidade de conhecer tudo em detalhes e, onde você vai ter todos os detalhes e ir aplicando tudo em seus projetos!
Lembro que, todos os nomes são fictícios! Alterem conforme seu projeto! Valeu Galera! Grande Abraço.