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 SubAgora, 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 SubBom! 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.