Sub AjustaColunas()
'
' Formata Macro
'
' Atalho do teclado: Ctrl+Shift+F
'
Cells.Select
Selection.RowHeight = 15
Cells.EntireColumn.AutoFit
Range("A2").Select
ActiveWindow.FreezePanes = True
End Sub
Private Sub CommandButton1_Click()
zpath
End Sub
Sub zpath()
Dim sh, n
Dim PathFilename As Variant
Dim FileName As String
FileName = "temp.sql"
PathFilename = Application.GetOpenFilename("ZipFile (*.zip), *.zip")
If PathFilename = "False" Then Exit Sub
TextBoxPath.Value = PathFilename
Set sh = CreateObject("shell.application")
Set n = sh.Namespace(PathFilename)
recur sh, n
End Sub
Sub recur(sh, n)
Dim i, subn
For Each i In n.items
If i.isfolder Then
Set subn = sh.Namespace(i)
recur sh, subn
Else
Debug.Print i.Path
End If
Next
End Sub
Option Explicit
Sub Separa()
Dim i As Integer
Dim x As Integer
Dim inicio As Integer
Dim contador As Integer
Dim caracteres As Integer
ReDim posicao(50) As Integer
ReDim texto(50) As String
'Determinar onde estão as quebras de linha
For i = 1 To Len(Range("A1"))
If Asc(Mid(Range("A1").Value, i, 1)) = 10 Then
posicao(contador) = i
contador = contador + 1
End If
Next
'Quebrar o texto
inicio = 1
caracteres = posicao(0)
'Primeiro
Debug.Print Mid(Range("A1").Value, inicio, caracteres - 1)
inicio = posicao(x)
caracteres = posicao(x + 1) - posicao(x)
'Segundo em diante
caracteres = posicao(1) - posicao(0)
For x = 1 To contador
'Último texto
If x = contador Then
caracteres = Len(Range("A1").Value)
texto(x) = Mid(Range("A1").Value, inicio + 1, caracteres - posicao(x) - 1)
Debug.Print texto(x)
Exit For
End If
texto(x + 1) = Mid(Range("A1").Value, inicio + 1, caracteres - 1)
Debug.Print texto(x + 1)
inicio = posicao(x)
caracteres = posicao(x + 1) - inicio
Next
End Sub
Option Explicit
Sub PreencheCelula()
ActiveDocument.Tables(1).Rows(1).Cells(2).Range.Text = "Linha 1, coluna 2"
ActiveDocument.Tables(1).Cell(2, 2).Range.Text = "Linha 2, coluna 2"
ActiveDocument.Tables(1).Columns(2).Cells(3).Range.Text = "Linha 3, coluna 2"
End Sub
Public Function modulo_10(sOrigem As String) As String
' Função para cálculo do dígito de auto conferência
Dim iK As Integer ' Contador
Dim iValor As Integer ' Variável para acumular valor
Dim iDigito As Integer ' Variável para o conteúdo de cada posição
iValor = 0
For iK = Len(sOrigem) To 1 Step -2 ' Inicia o laço começando da direita para a esquerda pulando 2 posições
iDigito = (Val(sOrigem) \ (10 ^ (Len(sOrigem) - iK))) Mod 10
If (iDigito * 2) >= 10 Then ' Se a multiplicação for maior ou igual a dez, soma-se os dígitos separadamente
iValor = iValor + (((iDigito * 2) \ 10) + (iDigito * 2) Mod 10)
Else ' Senão, multiplica-se e soma-se ao total
iValor = iValor + (iDigito * 2)
End If
If (iK - 1) <= Len(sOrigem) Then
' Se não ultrapassar otamanho da string, soma-se ao total
iDigito = (Val(sOrigem) \ (10 ^ (Len(sOrigem) - (iK - 1)))) Mod 10
iValor = iValor + iDigito
End If
Next iK
modulo_10 = Trim(Str((10 - IIf((iValor Mod 10) = 0, 10, (iValor Mod 10)))))
' Retorna o DAC
End Function
Private Sub Texto1_KeyPress(KeyAscii As Integer)
If InStr(1, "0123456789" & vbKeyDelete & Chr(8), Chr(KeyAscii)) = 0 Then
KeyAscii = 0
End If
End Sub
;-)
Public Function fn_SoNumeros(texto As String) As Double
Dim i As Integer
Dim valor As String
Application.Volatile
'Loop de 1 a quantidade de caracteres da célula
For i = 1 To Len(texto)
'Se caracter for numérico, concatena na string
If IsNumeric(Mid(texto, i, 1)) Then valor = valor & Mid(texto, i, 1)
Next
fn_SoNumeros = valor
End Function
Sub Listar_emails_Access()
Dim rst As New ADODB.Recordset
Dim cnn As New ADODB.Connection
Dim contador_itens As Integer
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & "C:Base.accdb"
rst.Open "Tabela1", cnn, adOpenKeyset, adLockOptimistic
contador_itens = fld.Items.Count
For Each itm In fld.Items
If itm.Class = olMail Then
rst.AddNew
rst!titulo = itm.Subject
rst!Data = itm.ReceivedTime
rst.Update
End If
Next itm
rst.Close
cnn.Close
MsgBox "Fim"
End Subv
Public Function ConverterHTML(textoHTML) As String
Dim Hdoc As New HTMLDocument
Hdoc.body.innerHTML = textoHTML
ConverterHTML = Hdoc.body.innerText
End Function
Public Function fn_CalculoParcelas(vlr_empresstimo As Double, _
taxa As Double, _
qtd_parcelas As Integer, _
data_contratacao As String, _
vcto_primeira_parcela As String) As Double
'Para passar os argumentos desta função:
'Informar valores no padrão americano (ponto no lugar de vírgula)
'Informar data entre aspas duplas (string)
'Informat a taxa em percentual. Exemplo 1,5% -> informar 0.015
Dim i As Integer
Dim c_price_total As Double
Dim c_price_parcela As Double
Dim tx_ao_dia As Double
'Cálculo do coeficiente price total
c_price_total = 0
tx_ao_dia = Fix((((taxa + 1) ^ (1 / 30) - 1) * 100) * 1000000000) / 1000000000
'Cálculo das parcelas
For i = 1 To qtd_parcelas
c_price_parcela = Fix(1 / ((tx_ao_dia / 100 + 1) ^ _
((DateAdd("M", i, CDate(data_contratacao)) - CDate(data_contratacao)))) * 1000000000) / 1000000000
c_price_total = c_price_total + c_price_parcela
Next
c_price_total = Fix(1 / c_price_total * 1000000000) / 1000000000
'Coeficiente total X (valor da proposta - entrada) = valor da parcela sem desconto
fn_CalculoParcelas = Format((vlr_empresstimo) * Round(c_price_total, 8), "#,##0.00")
End Function
;-)
