Skip to content

Instantly share code, notes, and snippets.

@fernandofig

fernandofig/DataManipulationUtils.vb

Last active August 12, 2021 05:35
Show Gist options
  • Save fernandofig/938cad4e0235a1f8e249 to your computer and use it in GitHub Desktop.
Save fernandofig/938cad4e0235a1f8e249 to your computer and use it in GitHub Desktop.
Download ZIP
Useful VBA / Excel Macros for Maillisting Normalization
Raw
clsMD5.vb
Option Explicit
'*******************************************************************************
' MODULE: CMD5
' FILENAME: C:\My Code\vb\md5\CMD5.cls
' AUTHOR: Phil Fresle
' CREATED: 16-Feb-2001
' COPYRIGHT: Copyright 2001 Frez Systems Limited. All Rights Reserved.
'
' DESCRIPTION:
' Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm,
' as set out in the memo RFC1321.
'
' This class is used to generate an MD5 'digest' or 'signature' of a string. The
' MD5 algorithm is one of the industry standard methods for generating digital
' signatures. It is generically known as a digest, digital signature, one-way
' encryption, hash or checksum algorithm. A common use for MD5 is for password
' encryption as it is one-way in nature, that does not mean that your passwords
' are not free from a dictionary attack. If you are using the
' routine for passwords, you can make it a little more secure by concatenating
' some known random characters to the password before you generate the signature
' and on subsequent tests, so even if a hacker knows you are using MD5 for
' your passwords, the random characters will make it harder to dictionary attack.
'
' *** CAUTION ***
' See the comment attached to the MD5 method below regarding use on systems
' with different character sets.
'
' This is 'free' software with the following restrictions:
'
' You may not redistribute this code as a 'sample' or 'demo'. However, you are free
' to use the source code in your own code, but you may not claim that you created
' the sample code. It is expressly forbidden to sell or profit from this source code
' other than by the knowledge gained or the enhanced value added by your own code.
'
' Use of this software is also done so at your own risk. The code is supplied as
' is without warranty or guarantee of any kind.
'
' Should you wish to commission some derivative work based on this code provided
' here, or any consultancy work, please do not hesitate to contact us.
'
' Web Site: http://www.frez.co.uk
' E-mail: sales@frez.co.uk
'
' MODIFICATION HISTORY:
' 1.0 16-Feb-2001
' Phil Fresle
' Initial Version
'*******************************************************************************
Private Const BITS_TO_A_BYTE As Long = 8
Private Const BYTES_TO_A_WORD As Long = 4
Private Const BITS_TO_A_WORD As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE
Private m_lOnBits(0 To 30) As Long
Private m_l2Power(0 To 30) As Long
'*******************************************************************************
' Class_Initialize (SUB)
'
' DESCRIPTION:
' We will usually get quicker results by preparing arrays of bit patterns and
' powers of 2 ahead of time instead of calculating them every time, unless of
' course the methods are only ever getting called once per instantiation of the
' class.
'*******************************************************************************
Private Sub Class_Initialize()
' Could have done this with a loop calculating each value, but simply
' assigning the values is quicker - BITS SET FROM RIGHT
m_lOnBits(0) = 1 ' 00000000000000000000000000000001
m_lOnBits(1) = 3 ' 00000000000000000000000000000011
m_lOnBits(2) = 7 ' 00000000000000000000000000000111
m_lOnBits(3) = 15 ' 00000000000000000000000000001111
m_lOnBits(4) = 31 ' 00000000000000000000000000011111
m_lOnBits(5) = 63 ' 00000000000000000000000000111111
m_lOnBits(6) = 127 ' 00000000000000000000000001111111
m_lOnBits(7) = 255 ' 00000000000000000000000011111111
m_lOnBits(8) = 511 ' 00000000000000000000000111111111
m_lOnBits(9) = 1023 ' 00000000000000000000001111111111
m_lOnBits(10) = 2047 ' 00000000000000000000011111111111
m_lOnBits(11) = 4095 ' 00000000000000000000111111111111
m_lOnBits(12) = 8191 ' 00000000000000000001111111111111
m_lOnBits(13) = 16383 ' 00000000000000000011111111111111
m_lOnBits(14) = 32767 ' 00000000000000000111111111111111
m_lOnBits(15) = 65535 ' 00000000000000001111111111111111
m_lOnBits(16) = 131071 ' 00000000000000011111111111111111
m_lOnBits(17) = 262143 ' 00000000000000111111111111111111
m_lOnBits(18) = 524287 ' 00000000000001111111111111111111
m_lOnBits(19) = 1048575 ' 00000000000011111111111111111111
m_lOnBits(20) = 2097151 ' 00000000000111111111111111111111
m_lOnBits(21) = 4194303 ' 00000000001111111111111111111111
m_lOnBits(22) = 8388607 ' 00000000011111111111111111111111
m_lOnBits(23) = 16777215 ' 00000000111111111111111111111111
m_lOnBits(24) = 33554431 ' 00000001111111111111111111111111
m_lOnBits(25) = 67108863 ' 00000011111111111111111111111111
m_lOnBits(26) = 134217727 ' 00000111111111111111111111111111
m_lOnBits(27) = 268435455 ' 00001111111111111111111111111111
m_lOnBits(28) = 536870911 ' 00011111111111111111111111111111
m_lOnBits(29) = 1073741823 ' 00111111111111111111111111111111
m_lOnBits(30) = 2147483647 ' 01111111111111111111111111111111
' Could have done this with a loop calculating each value, but simply
' assigning the values is quicker - POWERS OF 2
m_l2Power(0) = 1 ' 00000000000000000000000000000001
m_l2Power(1) = 2 ' 00000000000000000000000000000010
m_l2Power(2) = 4 ' 00000000000000000000000000000100
m_l2Power(3) = 8 ' 00000000000000000000000000001000
m_l2Power(4) = 16 ' 00000000000000000000000000010000
m_l2Power(5) = 32 ' 00000000000000000000000000100000
m_l2Power(6) = 64 ' 00000000000000000000000001000000
m_l2Power(7) = 128 ' 00000000000000000000000010000000
m_l2Power(8) = 256 ' 00000000000000000000000100000000
m_l2Power(9) = 512 ' 00000000000000000000001000000000
m_l2Power(10) = 1024 ' 00000000000000000000010000000000
m_l2Power(11) = 2048 ' 00000000000000000000100000000000
m_l2Power(12) = 4096 ' 00000000000000000001000000000000
m_l2Power(13) = 8192 ' 00000000000000000010000000000000
m_l2Power(14) = 16384 ' 00000000000000000100000000000000
m_l2Power(15) = 32768 ' 00000000000000001000000000000000
m_l2Power(16) = 65536 ' 00000000000000010000000000000000
m_l2Power(17) = 131072 ' 00000000000000100000000000000000
m_l2Power(18) = 262144 ' 00000000000001000000000000000000
m_l2Power(19) = 524288 ' 00000000000010000000000000000000
m_l2Power(20) = 1048576 ' 00000000000100000000000000000000
m_l2Power(21) = 2097152 ' 00000000001000000000000000000000
m_l2Power(22) = 4194304 ' 00000000010000000000000000000000
m_l2Power(23) = 8388608 ' 00000000100000000000000000000000
m_l2Power(24) = 16777216 ' 00000001000000000000000000000000
m_l2Power(25) = 33554432 ' 00000010000000000000000000000000
m_l2Power(26) = 67108864 ' 00000100000000000000000000000000
m_l2Power(27) = 134217728 ' 00001000000000000000000000000000
m_l2Power(28) = 268435456 ' 00010000000000000000000000000000
m_l2Power(29) = 536870912 ' 00100000000000000000000000000000
m_l2Power(30) = 1073741824 ' 01000000000000000000000000000000
End Sub
'*******************************************************************************
' LShift (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long - The value to be shifted
' (In) - iShiftBits - Integer - The number of bits to shift the value by
'
' RETURN VALUE:
' Long - The shifted long integer
'
' DESCRIPTION:
' A left shift takes all the set binary bits and moves them left, in-filling
' with zeros in the vacated bits on the right. This function is equivalent to
' the << operator in Java and C++
'*******************************************************************************
Private Function LShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
' NOTE: If you can guarantee that the Shift parameter will be in the
' range 1 to 30 you can safely strip of this first nested if structure for
' speed.
'
' A shift of zero is no shift at all.
If iShiftBits = 0 Then
LShift = lValue
Exit Function
' A shift of 31 will result in the right most bit becoming the left most
' bit and all other bits being cleared
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
' A shift of less than zero or more than 31 is undefined
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
' If the left most bit that remains will end up in the negative bit
' position (&H80000000) we would end up with an overflow if we took the
' standard route. We need to strip the left most bit and add it back
' afterwards.
If (lValue And m_l2Power(31 - iShiftBits)) Then
' (Value And OnBits(31 - (Shift + 1))) chops off the left most bits that
' we are shifting into, but also the left most bit we still want as this
' is going to end up in the negative bit marker position (&H80000000).
' After the multiplication/shift we Or the result with &H80000000 to
' turn the negative bit on.
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _
m_l2Power(iShiftBits)) Or &H80000000
Else
' (Value And OnBits(31-Shift)) chops off the left most bits that we are
' shifting into so we do not get an overflow error when we do the
' multiplication/shift
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _
m_l2Power(iShiftBits))
End If
End Function
'*******************************************************************************
' RShift (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long - The value to be shifted
' (In) - iShiftBits - Integer - The number of bits to shift the value by
'
' RETURN VALUE:
' Long - The shifted long integer
'
' DESCRIPTION:
' The right shift of an unsigned long integer involves shifting all the set bits
' to the right and in-filling on the left with zeros. This function is
' equivalent to the >>> operator in Java or the >> operator in C++ when used on
' an unsigned long.
'*******************************************************************************
Private Function RShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
' NOTE: If you can guarantee that the Shift parameter will be in the
' range 1 to 30 you can safely strip of this first nested if structure for
' speed.
'
' A shift of zero is no shift at all
If iShiftBits = 0 Then
RShift = lValue
Exit Function
' A shift of 31 will clear all bits and move the left most bit to the right
' most bit position
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
' A shift of less than zero or more than 31 is undefined
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
' We do not care about the top most bit or the final bit, the top most bit
' will be taken into account in the next stage, the final bit (whether it
' is an odd number or not) is being shifted into, so we do not give a jot
' about it
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
' If the top most bit (&H80000000) was set we need to do things differently
' as in a normal VB signed long integer the top most bit is used to indicate
' the sign of the number, when it is set it is a negative number, so just
' deviding by a factor of 2 as above would not work.
' NOTE: (lValue And &H80000000) is equivalent to (lValue < 0), you could
' get a very marginal speed improvement by changing the test to (lValue < 0)
If (lValue And &H80000000) Then
' We take the value computed so far, and then add the left most negative
' bit after it has been shifted to the right the appropriate number of
' places
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
'*******************************************************************************
' RShiftSigned (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long -
' (In) - iShiftBits - Integer -
'
' RETURN VALUE:
' Long -
'
' DESCRIPTION:
' The right shift of a signed long integer involves shifting all the set bits to
' the right and in-filling on the left with the sign bit (0 if positive, 1 if
' negative. This function is equivalent to the >> operator in Java or the >>
' operator in C++ when used on a signed long integer. Not used in this class,
' but included for completeness.
'*******************************************************************************
Private Function RShiftSigned(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
' NOTE: If you can guarantee that the Shift parameter will be in the
' range 1 to 30 you can safely strip of this first nested if structure for
' speed.
'
' A shift of zero is no shift at all
If iShiftBits = 0 Then
RShiftSigned = lValue
Exit Function
' A shift of 31 will clear all bits if the left most bit was zero, and will
' set all bits if the left most bit was 1 (a negative indicator)
ElseIf iShiftBits = 31 Then
' NOTE: (lValue And &H80000000) is equivalent to (lValue < 0), you
' could get a very marginal speed improvement by changing the test to
' (lValue < 0)
If (lValue And &H80000000) Then
RShiftSigned = -1
Else
RShiftSigned = 0
End If
Exit Function
' A shift of less than zero or more than 31 is undefined
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
' We get the same result by dividing by the appropriate power of 2 and
' rounding in the negative direction
RShiftSigned = Int(lValue / m_l2Power(iShiftBits))
End Function
'*******************************************************************************
' RotateLeft (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long - Value to act on
' (In) - iShiftBits - Integer - Bits to move by
'
' RETURN VALUE:
' Long - Result
'
' DESCRIPTION:
' Rotates the bits in a long integer to the left, those bits falling off the
' left edge are put back on the right edge
'*******************************************************************************
Private Function RotateLeft(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
'*******************************************************************************
' AddUnsigned (FUNCTION)
'
' PARAMETERS:
' (In) - lX - Long - First value
' (In) - lY - Long - Second value
'
' RETURN VALUE:
' Long - Result
'
' DESCRIPTION:
' Adds two potentially large unsigned numbers without overflowing
'*******************************************************************************
Private Function AddUnsigned(ByVal lX As Long, _
ByVal lY As Long) As Long
Dim lX4 As Long
Dim lY4 As Long
Dim lX8 As Long
Dim lY8 As Long
Dim lResult As Long
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
'*******************************************************************************
' F (FUNCTION)
'
' DESCRIPTION:
' MD5's F function
'*******************************************************************************
Private Function F(ByVal x As Long, _
ByVal y As Long, _
ByVal z As Long) As Long
F = (x And y) Or ((Not x) And z)
End Function
'*******************************************************************************
' G (FUNCTION)
'
' DESCRIPTION:
' MD5's G function
'*******************************************************************************
Private Function G(ByVal x As Long, _
ByVal y As Long, _
ByVal z As Long) As Long
G = (x And z) Or (y And (Not z))
End Function
'*******************************************************************************
' H (FUNCTION)
'
' DESCRIPTION:
' MD5's H function
'*******************************************************************************
Private Function H(ByVal x As Long, _
ByVal y As Long, _
ByVal z As Long) As Long
H = (x Xor y Xor z)
End Function
'*******************************************************************************
' I (FUNCTION)
'
' DESCRIPTION:
' MD5's I function
'*******************************************************************************
Private Function I(ByVal x As Long, _
ByVal y As Long, _
ByVal z As Long) As Long
I = (y Xor (x Or (Not z)))
End Function
'*******************************************************************************
' FF (SUB)
'
' DESCRIPTION:
' MD5's FF procedure
'*******************************************************************************
Private Sub FF(a As Long, _
ByVal b As Long, _
ByVal c As Long, _
ByVal d As Long, _
ByVal x As Long, _
ByVal s As Long, _
ByVal ac As Long)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
'*******************************************************************************
' GG (SUB)
'
' DESCRIPTION:
' MD5's GG procedure
'*******************************************************************************
Private Sub GG(a As Long, _
ByVal b As Long, _
ByVal c As Long, _
ByVal d As Long, _
ByVal x As Long, _
ByVal s As Long, _
ByVal ac As Long)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
'*******************************************************************************
' HH (SUB)
'
' DESCRIPTION:
' MD5's HH procedure
'*******************************************************************************
Private Sub HH(a As Long, _
ByVal b As Long, _
ByVal c As Long, _
ByVal d As Long, _
ByVal x As Long, _
ByVal s As Long, _
ByVal ac As Long)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
'*******************************************************************************
' II (SUB)
'
' DESCRIPTION:
' MD5's II procedure
'*******************************************************************************
Private Sub II(a As Long, _
ByVal b As Long, _
ByVal c As Long, _
ByVal d As Long, _
ByVal x As Long, _
ByVal s As Long, _
ByVal ac As Long)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(I(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
'*******************************************************************************
' ConvertToWordArray (FUNCTION)
'
' PARAMETERS:
' (In/Out) - sMessage - String - String message
'
' RETURN VALUE:
' Long() - Converted message as long array
'
' DESCRIPTION:
' Takes the string message and puts it in a long array with padding according to
' the MD5 rules.
'*******************************************************************************
Private Function ConvertToWordArray(sMessage As String) As Long()
Dim lMessageLength As Long
Dim lNumberOfWords As Long
Dim lWordArray() As Long
Dim lBytePosition As Long
Dim lByteCount As Long
Dim lWordCount As Long
Const MODULUS_BITS As Long = 512
Const CONGRUENT_BITS As Long = 448
lMessageLength = Len(sMessage)
' Get padded number of words. Message needs to be congruent to 448 bits,
' modulo 512 bits. If it is exactly congruent to 448 bits, modulo 512 bits
' it must still have another 512 bits added. 512 bits = 64 bytes
' (or 16 * 4 byte words), 448 bits = 56 bytes. This means lMessageSize must
' be a multiple of 16 (i.e. 16 * 4 (bytes) * 8 (bits))
lNumberOfWords = (((lMessageLength + _
((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ _
(MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * _
(MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
' Combine each block of 4 bytes (ascii code of character) into one long
' value and store in the message. The high-order (most significant) bit of
' each byte is listed first. However, the low-order (least significant) byte
' is given first in each word.
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
' Each word is 4 bytes
lWordCount = lByteCount \ BYTES_TO_A_WORD
' The bytes are put in the word from the right most edge
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or _
LShift(AscB(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
' Terminate according to MD5 rules with a 1 bit, zeros and the length in
' bits stored in the last two words
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
' Add a terminating 1 bit, all the rest of the bits to the end of the
' word array will default to zero
lWordArray(lWordCount) = lWordArray(lWordCount) Or _
LShift(&H80, lBytePosition)
' We put the length of the message in bits into the last two words, to get
' the length in bits we need to multiply by 8 (or left shift 3). This left
' shifted value is put in the first word. Any bits shifted off the left edge
' need to be put in the second word, we can work out which bits by shifting
' right the length by 29 bits.
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
'*******************************************************************************
' WordToHex (FUNCTION)
'
' PARAMETERS:
' (In) - lValue - Long - Long value to convert
'
' RETURN VALUE:
' String - Hex value to return
'
' DESCRIPTION:
' Takes a long integer and due to the bytes reverse order it extracts the
' individual bytes and converts them to hex appending them for an overall hex
' value
'*******************************************************************************
Private Function WordToHex(ByVal lValue As Long) As String
Dim lByte As Long
Dim lCount As Long
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And _
m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
'*******************************************************************************
' MD5 (FUNCTION)
'
' PARAMETERS:
' (In/Out) - sMessage - String - String to be digested
'
' RETURN VALUE:
' String - The MD5 digest
'
' DESCRIPTION:
' This function takes a string message and generates an MD5 digest for it.
' sMessage can be up to the VB string length limit of 2^31 (approx. 2 billion)
' characters.
'
' NOTE: Due to the way in which the string is processed the routine assumes a
' single byte character set. VB passes unicode (2-byte) character strings, the
' ConvertToWordArray function uses on the first byte for each character. This
' has been done this way for ease of use, to make the routine truely portable
' you could accept a byte array instead, it would then be up to the calling
' routine to make sure that the byte array is generated from their string in
' a manner consistent with the string type.
'*******************************************************************************
Public Function MD5(sMessage As String) As String
Dim x() As Long
Dim k As Long
Dim AA As Long
Dim BB As Long
Dim CC As Long
Dim DD As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Const S11 As Long = 7
Const S12 As Long = 12
Const S13 As Long = 17
Const S14 As Long = 22
Const S21 As Long = 5
Const S22 As Long = 9
Const S23 As Long = 14
Const S24 As Long = 20
Const S31 As Long = 4
Const S32 As Long = 11
Const S33 As Long = 16
Const S34 As Long = 23
Const S41 As Long = 6
Const S42 As Long = 10
Const S43 As Long = 15
Const S44 As Long = 21
' Steps 1 and 2. Append padding bits and length and convert to words
x = ConvertToWordArray(sMessage)
' Step 3. Initialise
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
' Step 4. Process the message in 16-word blocks
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
' The hex number on the end of each of the following procedure calls is
' an element from the 64 element table constructed with
' T(i) = Int(4294967296 * Abs(Sin(i))) where i is 1 to 64.
'
' However, for speed we don't want to calculate the value every time.
FF a, b, c, d, x(k + 0), S11, &HD76AA478
FF d, a, b, c, x(k + 1), S12, &HE8C7B756
FF c, d, a, b, x(k + 2), S13, &H242070DB
FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
FF d, a, b, c, x(k + 5), S12, &H4787C62A
FF c, d, a, b, x(k + 6), S13, &HA8304613
FF b, c, d, a, x(k + 7), S14, &HFD469501
FF a, b, c, d, x(k + 8), S11, &H698098D8
FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
FF b, c, d, a, x(k + 11), S14, &H895CD7BE
FF a, b, c, d, x(k + 12), S11, &H6B901122
FF d, a, b, c, x(k + 13), S12, &HFD987193
FF c, d, a, b, x(k + 14), S13, &HA679438E
FF b, c, d, a, x(k + 15), S14, &H49B40821
GG a, b, c, d, x(k + 1), S21, &HF61E2562
GG d, a, b, c, x(k + 6), S22, &HC040B340
GG c, d, a, b, x(k + 11), S23, &H265E5A51
GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
GG a, b, c, d, x(k + 5), S21, &HD62F105D
GG d, a, b, c, x(k + 10), S22, &H2441453
GG c, d, a, b, x(k + 15), S23, &HD8A1E681
GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
GG d, a, b, c, x(k + 14), S22, &HC33707D6
GG c, d, a, b, x(k + 3), S23, &HF4D50D87
GG b, c, d, a, x(k + 8), S24, &H455A14ED
GG a, b, c, d, x(k + 13), S21, &HA9E3E905
GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
GG c, d, a, b, x(k + 7), S23, &H676F02D9
GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
HH a, b, c, d, x(k + 5), S31, &HFFFA3942
HH d, a, b, c, x(k + 8), S32, &H8771F681
HH c, d, a, b, x(k + 11), S33, &H6D9D6122
HH b, c, d, a, x(k + 14), S34, &HFDE5380C
HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
HH a, b, c, d, x(k + 13), S31, &H289B7EC6
HH d, a, b, c, x(k + 0), S32, &HEAA127FA
HH c, d, a, b, x(k + 3), S33, &HD4EF3085
HH b, c, d, a, x(k + 6), S34, &H4881D05
HH a, b, c, d, x(k + 9), S31, &HD9D4D039
HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
HH b, c, d, a, x(k + 2), S34, &HC4AC5665
II a, b, c, d, x(k + 0), S41, &HF4292244
II d, a, b, c, x(k + 7), S42, &H432AFF97
II c, d, a, b, x(k + 14), S43, &HAB9423A7
II b, c, d, a, x(k + 5), S44, &HFC93A039
II a, b, c, d, x(k + 12), S41, &H655B59C3
II d, a, b, c, x(k + 3), S42, &H8F0CCC92
II c, d, a, b, x(k + 10), S43, &HFFEFF47D
II b, c, d, a, x(k + 1), S44, &H85845DD1
II a, b, c, d, x(k + 8), S41, &H6FA87E4F
II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
II c, d, a, b, x(k + 6), S43, &HA3014314
II b, c, d, a, x(k + 13), S44, &H4E0811A1
II a, b, c, d, x(k + 4), S41, &HF7537E82
II d, a, b, c, x(k + 11), S42, &HBD3AF235
II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
II b, c, d, a, x(k + 9), S44, &HEB86D391
a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next
' Step 5. Output the 128 bit digest
MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
End Function
Raw
DataManipulationUtils.vb
Sub GeraEndereco()
Dim endFinal As String
Dim myRange As Range
Set myRange = Selection
lf = myRange.Row + myRange.Rows.Count - 1
cf = myRange.Column + myRange.Columns.Count - 1
For l = myRange.Row To lf
For c = myRange.Column To cf
Select Case c
Case myRange.Column:
endFinal = Trim(Cells(l, c).Value2)
Case myRange.Column + 1:
If Trim(Cells(l, c).Value2) <> "" Then endFinal = endFinal & ", " & Trim(Cells(l, c).Value2)
Case Else
If Trim(Cells(l, c).Value2) <> "" Then endFinal = endFinal & " - " & Trim(Cells(l, c).Value2)
End Select
Next
Cells(l, cf + 1).Value = endFinal
Next
End Sub
Sub DesabreviaEstado()
Dim endFinal As String
Dim Abrev(27) As String
Dim Descr(27) As String
Abrev(1) = "AC": Abrev(2) = "AL": Abrev(3) = "AP": Abrev(4) = "AM": Abrev(5) = "BA": Abrev(6) = "CE": Abrev(7) = "DF": Abrev(8) = "ES": Abrev(9) = "GO": Abrev(10) = "MA": Abrev(11) = "MT": Abrev(12) = "MS": Abrev(13) = "MG": Abrev(14) = "PA": Abrev(15) = "PB": Abrev(16) = "PR": Abrev(17) = "PE": Abrev(18) = "PI": Abrev(19) = "RJ": Abrev(20) = "RN": Abrev(21) = "RS": Abrev(22) = "RO": Abrev(23) = "RR": Abrev(24) = "SC": Abrev(25) = "SP": Abrev(26) = "SE": Abrev(27) = "TO"
Descr(1) = "Acre": Descr(2) = "Alagoas": Descr(3) = "Amapá": Descr(4) = "Amazonas": Descr(5) = "Bahia": Descr(6) = "Ceará": Descr(7) = "Distrito Federal": Descr(8) = "Espírito Santo": Descr(9) = "Goiás": Descr(10) = "Maranhão": Descr(11) = "Mato Grosso": Descr(12) = "Mato Grosso do Sul": Descr(13) = "Minas Gerais": Descr(14) = "Pará": Descr(15) = "Paraíba": Descr(16) = "Paraná": Descr(17) = "Pernambuco": Descr(18) = "Piauí": Descr(19) = "Rio de Janeiro": Descr(20) = "Rio Grande do Norte": Descr(21) = "Rio Grande do Sul": Descr(22) = "Rondônia": Descr(23) = "Roraima": Descr(24) = "Santa Catarina": Descr(25) = "São Paulo": Descr(26) = "Sergipe": Descr(27) = "Tocantins"
Dim myRange As Range
Set myRange = Selection
lf = myRange.Row + myRange.Rows.Count - 1
For l = myRange.Row To lf
For I = 1 To 27
If Trim(Cells(l, myRange.Column).Value2) = Abrev(I) Then
Cells(l, myRange.Column).Value = Descr(I)
Encontrou = True
Exit For
End If
Next
Next
End Sub
Sub FormataLiteral()
linha = ActiveCell.Row
While Cells(linha, ActiveCell.Column).Value <> ""
Cells(linha, ActiveCell.Column).Value = "'" & Cells(linha, ActiveCell.Column).Value
linha = linha + 1
Wend
End Sub
Sub FormataCNPJSemPontuacao()
linha = ActiveCell.Row
While Cells(linha, ActiveCell.Column).Value <> ""
CNPJ = Cells(linha, ActiveCell.Column).Value
CNPJ = Replace(Replace(Replace(Replace(CNPJ, ".", ""), "/", ""), "-", ""), " ", "")
'If Cells(linha, ActiveCell.Column).PrefixCharacter <> "'" Then CNPJ = "'" & CNPJ
Cells(linha, ActiveCell.Column).Value = "'" & CNPJ
linha = linha + 1
Wend
End Sub
Sub FormataCPFComPontuacao()
Dim cpfAtual As String, cpfFmt As String
Dim myRange As Range
Set myRange = Selection
lf = myRange.Row + myRange.Rows.Count - 1
cf = myRange.Column + myRange.Columns.Count - 1
For l = myRange.Row To lf
For c = myRange.Column To cf
cpfAtual = Cells(l, c).Value
If Trim(cpfAtual) <> "" And Len(Trim(cpfAtual)) = 11 Then
cmp = Len(cpfAtual)
cpfFmt = Left(cpfAtual, 3) & "." & _
Mid(cpfAtual, 4, 3) & "." & _
Mid(cpfAtual, 7, 3) & "-" & _
Right(cpfAtual, 2)
Cells(l, c).Value = cpfFmt
End If
Next
Next
End Sub
Sub FormataCNPJComPontuacao()
Dim cnpjAtual As String, cnpjFmt As String
Dim myRange As Range
Set myRange = Selection
lf = myRange.Row + myRange.Rows.Count - 1
cf = myRange.Column + myRange.Columns.Count - 1
For l = myRange.Row To lf
For c = myRange.Column To cf
cnpjAtual = Cells(l, c).Value
If Trim(cnpjAtual) <> "" And Len(Trim(cnpjAtual)) = 14 Then
cmp = Len(cnpjAtual)
cnpjFmt = Left(cnpjAtual, 2) & "." & _
Mid(cnpjAtual, cmp - 11, 3) & "." & _
Mid(cnpjAtual, cmp - 8, 3) & "/" & _
Mid(cnpjAtual, cmp - 5, 4) & "-" & _
Right(cnpjAtual, 2)
Cells(l, c).Value = cnpjFmt
End If
Next
Next
End Sub
Function PegaNumeroNFFromChave(chave As String) As String
serie = CInt(Mid(chave, 23, 3))
numero = CLng(Mid(chave, 26, 9))
PegaNumeroNFFromChave = CStr(numero) & "-" & CStr(serie)
End Function
Sub GeraQueriesRemoveLigacaoEntidade()
'
' GeraQueriesRemoveLigacaoEntidade Macro
'
Dim codEntBase As Variant, codEntsBase As String, codEntsBaseArr() As String, codEntsBaseArrGeral() As String
Dim criaAssocDoc As Boolean
startRow = ActiveCell.Row
l = startRow
ls = l
l = startRow
While Cells(l, 1).Value <> ""
codEntForn = Cells(l, 1).Value
If Cells(l, 2).Value <> "" And UBound(Split(Cells(l, 2).Value, ",")) > -1 Then
codEntsBaseArr = Split(Cells(l, 2).Value, ",")
For Each codEntBase In codEntsBaseArr
Cells(ls, 3).Value = "DELETE FROM ENTITY2ENTITY WHERE ENTITYCODE = '" & codEntBase & "' AND DESTINATIONENTITYCODE = '" & codEntForn & "';"
Cells(ls + 1, 3).Value = "DELETE FROM ENTITY2ENTITY WHERE ENTITYCODE = '" & codEntForn & "' AND DESTINATIONENTITYCODE = '" & codEntBase & "';"
ls = ls + 2
Next
End If
l = l + 1
Wend
End Sub
Sub GeraQueriesConfigEntidade()
'
' GeraQueriesLigacoes Macro
'
Dim codEntBase As Variant, codEntsBase As String, codEntsBaseArr() As String, codEntsBaseArrGeral() As String
Dim codEntsBaseArrGeralBound As Integer
Dim criaAssocDoc As Boolean
criaAssocDoc = MsgBox("Gerar queries de associação de tipos de documento?", vbYesNo, "Tipos de Doc.") = vbYes
'ReDim codEntsBaseArrGeral(0)
codEntsBaseArrGeralBound = -1
startRow = ActiveCell.Row
l = startRow
ls = l
Cells(ls, 3).Value = "UPDATE ENTITY SET CITY = STATE, STATE = COMMRECORDCONS WHERE CODE LIKE 'BR%' AND CITY IS NULL;"
ls = ls + 1
If criaAssocDoc Then
While Cells(l, 1).Value <> ""
If Cells(l, 2).Value <> "" And UBound(Split(Cells(l, 2).Value, ",")) > -1 Then
codEntsBaseArr = Split(Cells(l, 2).Value, ",")
For Each codEntBase In codEntsBaseArr
Inclui = True
If codEntsBaseArrGeralBound > -1 Then
For Each codEntBaseGeral In codEntsBaseArrGeral
If codEntBase = codEntBaseGeral Then Inclui = False
Next
End If
If Inclui Then
codEntsBaseArrGeralBound = codEntsBaseArrGeralBound + 1
ReDim Preserve codEntsBaseArrGeral(codEntsBaseArrGeralBound)
codEntsBaseArrGeral(codEntsBaseArrGeralBound) = codEntBase
End If
Next
End If
l = l + 1
Wend
For Each codEntBaseGeral In codEntsBaseArrGeral
'Cells(ls, 3).Value = "UPDATE ENTITY SET CITY = STATE, STATE = COMMRECORDCONS WHERE CODE = '" & codEntBaseGeral & "';"
'Cells(ls, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',1,1,NULL);"
'Cells(ls, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',1,2,NULL);"
Cells(ls, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',2,1,NULL);"
Cells(ls + 1, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',2,2,NULL);"
Cells(ls + 2, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',21,1,NULL);"
Cells(ls + 3, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',21,2,NULL);"
Cells(ls + 4, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',60,1,NULL);"
Cells(ls + 5, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',60,2,NULL);"
Cells(ls + 6, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',64,1,NULL);"
Cells(ls + 7, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',64,2,NULL);"
Cells(ls + 8, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',66,1,NULL);"
Cells(ls + 9, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',66,2,NULL);"
Cells(ls + 10, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',300,1,NULL);"
Cells(ls + 11, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',300,2,NULL);"
Cells(ls + 12, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',301,1,NULL);"
Cells(ls + 13, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',301,2,NULL);"
Cells(ls + 14, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',302,1,NULL);"
Cells(ls + 15, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',302,2,NULL);"
Cells(ls + 16, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',303,1,NULL);"
Cells(ls + 17, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntBaseGeral & "',303,2,NULL);"
ls = ls + 18
Next
End If
l = startRow
While Cells(l, 1).Value <> ""
codEntForn = Cells(l, 1).Value
If Cells(l, 2).Value <> "" And UBound(Split(Cells(l, 2).Value, ",")) > -1 Then
codEntsBaseArr = Split(Cells(l, 2).Value, ",")
'Cells(ls, 3).Value = "UPDATE ENTITY SET CITY = STATE, STATE = COMMRECORDCONS WHERE CODE = '" & codEntForn & "';"
'ls = ls + 1
For Each codEntBase In codEntsBaseArr
Cells(ls, 3).Value = "INSERT INTO ENTITY2ENTITY (ENTITYCODE, DESTINATIONENTITYCODE, STATUS, REASON, ENVIRONMENT, EFFECTIVITYDATE, AUTHORID, CONFIRMATIONDATE, REQUESTDATE, REQUESTAUTHORID, FINANCIALINFOID, FINANCIALINFODATE) VALUES ('" & _
codEntBase & "','" & codEntForn & "','INTEGRATED',NULL,'PROD',SYSTIMESTAMP,1,SYSTIMESTAMP,SYSTIMESTAMP,1,NULL,NULL);"
Cells(ls + 1, 3).Value = "INSERT INTO ENTITY2ENTITY (ENTITYCODE, DESTINATIONENTITYCODE, STATUS, REASON, ENVIRONMENT, EFFECTIVITYDATE, AUTHORID, CONFIRMATIONDATE, REQUESTDATE, REQUESTAUTHORID, FINANCIALINFOID, FINANCIALINFODATE) VALUES ('" & _
codEntForn & "','" & codEntBase & "','INTEGRATED',NULL,'PROD',SYSTIMESTAMP,1,SYSTIMESTAMP,SYSTIMESTAMP,1,NULL,NULL);"
ls = ls + 2
Next
If criaAssocDoc Then
'Cells(ls, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',1,1,NULL);"
'Cells(ls, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',1,2,NULL);"
Cells(ls, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',2,1,NULL);"
Cells(ls + 1, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',2,2,NULL);"
Cells(ls + 2, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',21,1,NULL);"
Cells(ls + 3, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',21,2,NULL);"
Cells(ls + 4, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',60,1,NULL);"
Cells(ls + 5, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',60,2,NULL);"
Cells(ls + 6, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',64,1,NULL);"
Cells(ls + 7, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',64,2,NULL);"
Cells(ls + 8, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',66,1,NULL);"
Cells(ls + 9, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',66,2,NULL);"
Cells(ls + 10, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',300,1,NULL);"
Cells(ls + 11, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',300,2,NULL);"
Cells(ls + 12, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',301,1,NULL);"
Cells(ls + 13, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',301,2,NULL);"
Cells(ls + 14, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',302,1,NULL);"
Cells(ls + 15, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',302,2,NULL);"
Cells(ls + 16, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',303,1,NULL);"
Cells(ls + 17, 3).Value = "INSERT INTO ENTITYDOCUMENT (ENTITYCODE, DOCTYPEID, DIRID, INTEGRATE) VALUES ('" & codEntForn & "',303,2,NULL);"
ls = ls + 18
End If
End If
l = l + 1
Wend
End Sub
Sub GeraQueriesUsuarios()
'
' GeraQueriesUsuarios Macro
'
l = ActiveCell.Row
ls = l + 2
oc = 7
Cells(l, oc).Value = "DECLARE lastId EIV_NETDOCS.USERS.ID%TYPE;"
Cells(l + 1, oc).Value = "BEGIN"
While Cells(l, 1).Value <> ""
codEntForn = Cells(l, 1).Value
lang = IIf(Left(Cells(l, 1).Value, 8) = "BR000000" Or Left(Cells(l, 1).Value, 2) <> "BR", "en", "pt-br")
eml = "NULL"
If Cells(l, 6).Value <> "" Then eml = "'" & Cells(l, 6).Value & "'"
qry = " INSERT INTO EIV_NETDOCS.USERS (ENTITYCODE,NAME,DELETED,USERNAME,PASSWD,EMAIL,STARTDATE,DUEDATE,CREATIONDATE,LASTCHANGEDATE,AUTHORID,PHONENUMBER,FAXNUMBER,LANGCODE,INTRANSPORTDOCUMENTID,PORTALENTITYCODE,TIMEZONE) " & _
"VALUES (" & _
"'" & Cells(l, 1).Value & "'" & _
",'" & Cells(l, 2).Value & "',0" & _
",'" & Cells(l, 3).Value & "'" & _
",'" & Cells(l, 5).Value & "'" & _
"," & eml & _
",SYSTIMESTAMP-7,NULL,SYSTIMESTAMP,SYSTIMESTAMP,1,NULL,NULL,'" & lang & "',NULL,'00','E. South America Standard Time') RETURNING ID INTO lastId; "
Cells(ls, oc).Value = qry
Cells(ls + 1, oc).Value = " INSERT INTO EIV_NETDOCS.USERS2ROLE (ROLEID, USERSID) VALUES (4, lastId);"
Cells(ls + 2, oc).Value = " INSERT INTO EIV_NETDOCS.USERS2ROLE (ROLEID, USERSID) VALUES (9, lastId);"
'Cells(ls + 3, 4).Value = " INSERT INTO EIV_NETDOCS.USERS2ENTITY (ENTITYCODE, USERSID) VALUES ('" & Cells(l, 2).Value & "', lastId);"
'UCase(MD5Hash.MD5Hash(Cells(l, 3).Value))
l = l + 1
ls = ls + 3
Wend
Cells(ls, oc).Value = "END;"
End Sub
Sub GeraQueriesNotifs()
'
' GeraQueriesNotifs Macro
'
Dim tiposEvento(3) As String
Dim qryPart As String
l = ActiveCell.Row
ls = l
oc = 3
tiposEvento(0) = "NOTIF_PAPER_DOCUMENT_RECEPTION"
tiposEvento(1) = "NOTIF_NON_FINANCIAL_DOCUMENT_RECEPTION"
tiposEvento(2) = "NOTIF_FINANCIAL_DOCUMENT_RECEPTION"
tiposEvento(3) = "NOTIF_NON_FINANCIAL_DOCUMENT_RECEPTION_CANCELED"
qryPart = "INSERT INTO EIV_NETDOCS.ENTITYNOTIFICATION (ENTITYCODE, ADDRESS, ADDRESSTYPECODE, EVENTTYPE, SENDDOCUMENTASATTACHMENT) VALUES ("
While Cells(l, 1).Value <> "" And Cells(l, 2).Value <> ""
codEntForn = Cells(l, 1).Value
For Each ev In tiposEvento
qry = qryPart & _
"'" & codEntForn & "'" & _
",'" & Cells(l, 2).Value & "'" & _
",'EMAIL'" & _
",'" & ev & "'" & _
",0);"
Cells(ls, oc).Value = qry
ls = ls + 1
Next
l = l + 1
Wend
End Sub
Sub TabulaEmailsComCNPJs()
Dim cLineSrc As Integer, cLineDst As Integer
Dim CodEntidade As String, mailList As String, mlListArr() As String
cLineSrc = ActiveCell.Row
cLineDst = ActiveCell.Row
While Cells(cLineSrc, 1).Value <> ""
CodEntidade = Trim(Cells(cLineSrc, 1).Value)
mailList = Trim(Cells(cLineSrc, 2).Value)
mailList = Replace(Replace(mailList, ",", ";"), " ", "")
mlListArr = Split(mailList, ";", -1, vbTextCompare)
For Each mail In mlListArr
Cells(cLineDst, 3).Value = CodEntidade
Cells(cLineDst, 4).Value = Trim(mail)
cLineDst = cLineDst + 1
Next
cLineSrc = cLineSrc + 1
Wend
End Sub
Function GeraNomeCurto(nome As String) As String
NomeSemEspaco = RegExReplace("[\s\t]{2,}", Trim(nome), " ")
PartesNome = Split(NomeSemEspaco, " ")
NomeFinal = ""
I = -1
Do
I = I + 1
NomeFinal = NomeFinal & " " & PartesNome(I)
Loop Until Len(PartesNome(I)) >= 3
GeraNomeCurto = Trim(NomeFinal)
End Function
Function SanizaAbrevIniciais(nome As String) As String
NomeSemEspaco = RegExReplace("[\s\t]{2,}", Trim(nome), " ")
PartesNome = Split(NomeSemEspaco, " ")
NomeFinal = ""
I = -1
Do
I = I + 1
ParteSanizada = PartesNome(I)
If Len(ParteSanizada) = 1 Then
ParteSanizada = ParteSanizada & "."
ElseIf uCase(ParteSanizada) = "LTDA" Then
ParteSanizada = "LTDA."
End If
NomeFinal = NomeFinal & " " & ParteSanizada
Loop Until I = UBound(PartesNome)
SanizaAbrevIniciais = Trim(NomeFinal)
End Function
Sub RemoveNDs()
l = ActiveCell.Row
c = ActiveCell.Column
While Cells(l, c).Text <> ""
loopStartNDs:
If Cells(l, c).Text = "#N/D" And Cells(l, c).Text <> "" Then
Rows(l).Select
Selection.Delete Shift:=xlUp
GoTo loopStartNDs
End If
l = l + 1
Wend
End Sub
Sub RemoveNaoNDs()
l = ActiveCell.Row
c = ActiveCell.Column
While Cells(l, c).Text <> ""
loopStartNaoNDs:
If Cells(l, c).Text <> "#N/D" And Cells(l, c).Text <> "" Then
Rows(l).Select
Selection.Delete Shift:=xlUp
GoTo loopStartNaoNDs
End If
l = l + 1
Wend
End Sub
Sub RemoveVazios()
l = ActiveCell.Row
c = ActiveCell.Column
While Cells(l, 1).Text <> ""
loopStartVazios:
If Trim(Cells(l, c).Text) = "" And Cells(l, 1).Text <> "" Then
Rows(l).Select
Selection.Delete Shift:=xlUp
GoTo loopStartVazios
End If
l = l + 1
Wend
End Sub
Sub GeraQueriesAtualizacaoValoresDOA()
'
' GeraQueriesAtualizacaoValoresDOA Macro
'
l = 2
ls = 2
cs = 2
While Cells(1, cs).Value <> ""
cs = cs + 1
Wend
While Cells(l, 1).Value <> ""
For ca = 2 To cs - 1
Cells(ls, cs).Value = "MERGE aplicacao_pessoa AS ap " & _
"USING (SELECT id_pessoa FROM pessoa WHERE login = '" & Cells(l, 1).Value & "') AS p " & _
"ON (ap.id_pessoa = p.id_pessoa AND ap.id_aplicacao = " & Cells(1, ca).Value & " AND ap.id_pais = 1) " & _
"WHEN NOT MATCHED BY TARGET THEN " & _
" INSERT (vl_aprovacao, cd_status, dt_inserted, id_pessoa, id_aplicacao, id_pais) " & _
" VALUES (" & Replace(Replace(Cells(l, ca).Value, ".", ""), ",", ".") & ", 'A', GETDATE(), p.id_pessoa, " & Cells(1, ca).Value & ", 1) " & _
"WHEN MATCHED THEN " & _
" UPDATE SET vl_aprovacao = " & Replace(Replace(Cells(l, ca).Value, ".", ""), ",", ".") & " " & _
";"
'"OUTPUT $action, inserted.*, deleted.*;" & _
ls = ls + 1
Next
l = l + 1
Wend
End Sub
Raw
Iluria.vb
Const IsWindows = True
Function ArrUBound(ByRef arr() As String) As Integer
If (Not Not arr) <> 0 Then
ArrUBound = UBound(arr)
Else
ArrUBound = -1
End If
End Function
Sub GeraProdutos()
'
' GeraProdutos Macro
'
Sheets("Produtos do Pedido").Select
li = 2
Dim _
Projetos() As String, _
Kits() As String, _
Bonecas() As String, _
Acessorios() As String, _
BaseMDF() As String, _
Rostinho() As String
Dim ListaFinal() As String
While Cells(li, 1).Value <> "" Or Cells(li, 2) <> "" Or Cells(li, 3) <> "" Or Cells(li, 4) <> ""
If Cells(li, 1).Value <> "" Then
elAtual = ArrUBound(Projetos) + 1
ReDim Preserve Projetos(elAtual)
Projetos(elAtual) = NormalizaNomeProduto(Cells(li, 1).Value)
End If
If Cells(li, 2).Value <> "" Then
elAtual = ArrUBound(Kits) + 1
ReDim Preserve Kits(elAtual)
Kits(elAtual) = NormalizaNomeProduto(Cells(li, 2).Value)
End If
If Cells(li, 3).Value <> "" Then
elAtual = ArrUBound(Acessorios) + 1
ReDim Preserve Acessorios(elAtual)
Acessorios(elAtual) = NormalizaNomeProduto(Cells(li, 3).Value)
End If
If Cells(li, 4).Value <> "" Then
elAtual = ArrUBound(BaseMDF) + 1
ReDim Preserve BaseMDF(elAtual)
BaseMDF(elAtual) = NormalizaNomeProduto(Cells(li, 4).Value)
End If
If Cells(li, 5).Value <> "" Then
elAtual = ArrUBound(Rostinho) + 1
ReDim Preserve Rostinho(elAtual)
Rostinho(elAtual) = NormalizaNomeProduto(Cells(li, 5).Value)
End If
If Cells(li, 6).Value <> "" Then
elAtual = ArrUBound(Bonecas) + 1
ReDim Preserve Bonecas(elAtual)
Bonecas(elAtual) = NormalizaNomeProduto(Cells(li, 6).Value)
End If
li = li + 1
Wend
Sheets("Pedidos").Select
sep = IIf(IsWindows, vbCrLf, vbCr)
sepSec = sep
If ArrUBound(Projetos) > -1 Then
ReDim Preserve ListaFinal(ArrUBound(ListaFinal) + 1)
ListaFinal(UBound(ListaFinal)) = "PROJETOS: " & Join(Projetos, sep)
End If
If ArrUBound(Kits) > -1 Then
ReDim Preserve ListaFinal(ArrUBound(ListaFinal) + 1)
ListaFinal(UBound(ListaFinal)) = "KITS: " & Join(Kits, sep)
End If
If ArrUBound(Acessorios) > -1 Then
ReDim Preserve ListaFinal(ArrUBound(ListaFinal) + 1)
ListaFinal(UBound(ListaFinal)) = "F & A: " & Join(Acessorios, sep)
End If
If ArrUBound(BaseMDF) > -1 Then
ReDim Preserve ListaFinal(ArrUBound(ListaFinal) + 1)
ListaFinal(UBound(ListaFinal)) = "BASE MDF: " & Join(BaseMDF, sep)
End If
If ArrUBound(Rostinho) > -1 Then
ReDim Preserve ListaFinal(ArrUBound(ListaFinal) + 1)
ListaFinal(UBound(ListaFinal)) = "ROSTINHOS: " & Join(Rostinho, sep)
End If
If ArrUBound(Bonecas) > -1 Then
ReDim Preserve ListaFinal(ArrUBound(ListaFinal) + 1)
ListaFinal(UBound(ListaFinal)) = "BONECAS: " & Join(Bonecas, sep)
End If
If ArrUBound(ListaFinal) > -1 Then
ActiveCell.Value = Join(ListaFinal, sepSec)
End If
Sheets("Produtos do Pedido").Select
Range("A2:F2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A2").Select
Sheets("Pedidos").Select
End Sub
Sub PreparaProdutosDecConteudo()
dli = 2
dci = 12
While Sheets(1).Cells(dli, dci).Value <> ""
dli = dli + 1
Wend
oli = ActiveCell.Row
oliOrig = oli
oci = ActiveCell.Column
Dim nomeItem As String
nomeItem = Cells(oli, oci).Value
While nomeItem <> ""
If InStr(1, LCase(nomeItem), "kit completo", vbTextCompare) > 0 Or InStr(1, LCase(nomeItem), "ciranda", vbTextCompare) > 0 Then
nomeItem = Replace(nomeItem, "(kit completo)", "")
nomeItem = Regex.RegExReplace(" - Mega Artesanal \d{4}", nomeItem, "", True, True)
nomeItem = Regex.RegExReplace("\(.*s.cios da ciranda.+\)", nomeItem, "", True, True)
nomeItem = Regex.RegExReplace("\s{2,}", nomeItem, " ", True, True)
nomeItem = Trim("Kit de montagem de Boneca: " + nomeItem)
End If
QtdNum = Regex.RegExExtract("(.+)Qtd.: (\d+)(.*)", nomeItem, "$2", False, True, False)
If QtdNum <> "" Then
Sheets(1).Cells(dli, dci).Value = Regex.RegExReplace("Qtd.: \d+", nomeItem, "", True, True)
Sheets(1).Cells(dli, dci).Value = Replace(Replace(Replace(nomeItem, "( / ", "("), " / )", ""), "()", "")
Sheets(1).Cells(dli, dci + 1).Value = QtdNum
Else
Sheets(1).Cells(dli, dci).Value = nomeItem
Sheets(1).Cells(dli, dci + 1).Value = "1"
End If
dci = dci + 3
oli = oli + 1
nomeItem = Cells(oli, oci).Value
Wend
Sheets(3).Range(Cells(oliOrig, oci), Cells(oli - 1, oci)).Select
Sheets(1).Select
End Sub
Function NormalizaNomeProduto(nomeProd As String) As String
Dim Lixo(9) As String
Lixo(0) = "(projeto)"
Lixo(1) = "- projeto"
Lixo(2) = "projeto"
Lixo(3) = "(kit completo)"
Lixo(4) = "( kit completo)"
Lixo(5) = "- kit completo"
Lixo(6) = "(kit)"
Lixo(7) = "- kit"
Lixo(8) = "(Base MDF)"
Lixo(9) = "Rostinho Pintadinho -"
For I = 0 To UBound(Lixo)
nomeProd = Replace(nomeProd, Lixo(I), "", 1, -1, vbTextCompare)
Next
NormalizaNomeProduto = Replace(Replace(Trim(nomeProd), " ", " "), " ", " ")
End Function
Sub LimpaCSVIluria_Pedidos()
'
' LimpaCSVIluria Macro
'
Columns("B:F").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("D:F").Select
Selection.Delete Shift:=xlToLeft
'Columns("H:H").Select
'Selection.Delete Shift:=xlToLeft
Columns("M:M").Select
Selection.Delete Shift:=xlToLeft
Columns("O:P").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Columns("B:C").Select
Selection.Cut
Columns("M:M").Select
Selection.Insert Shift:=xlToRight
Selection.Cut
Columns("L:L").Select
Selection.Insert Shift:=xlToRight
Columns("M:M").Select
Selection.Cut
Columns("P:P").Select
Selection.Insert Shift:=xlToRight
'Rows("1:1").Select
'Application.CutCopyMode = False
'Selection.Delete Shift:=xlUp
linha = 2
While Cells(linha, 1).Value <> ""
Cells(linha, 1).Value = "'" & Cells(linha, 1).Value
If Cells(linha, 3).Value <> Cells(linha, 16).Value Then Cells(linha, 3).Value = Cells(linha, 16).Value
If InStr(1, Cells(linha, 11).Value, "Fixo", vbBinaryCompare) > 0 Then Cells(linha, 11).Value = "FIXO"
cpfAtual = Cells(linha, 13).Value
If Trim(cpfAtual) <> "" And Len(Trim(cpfAtual)) = 11 Then
cmp = Len(cpfAtual)
cpfFmt = Left(cpfAtual, 3) & "." & _
Mid(cpfAtual, 4, 3) & "." & _
Mid(cpfAtual, 7, 3) & "-" & _
Right(cpfAtual, 2)
Cells(linha, 13).Value = cpfFmt
End If
Cells(linha, 15) = "R$ " & FormatNumber(Cells(linha, 15), 2, vbUseDefault, vbFalse, vbTrue)
linha = linha + 1
Wend
Columns("P:P").Select
Selection.Delete Shift:=xlToLeft
Columns("L:L").AutoFit
Columns("M:M").AutoFit
Range("A1:L1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
End Sub
Sub LimpaCSVIluria_Produtos()
'
' LimpaCSVIluria Macro
'
Columns("B:C").Select
Selection.Delete Shift:=xlToLeft
'Columns("E:H").Select
'Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
'Rows("1:1").Select
'Application.CutCopyMode = False
'Selection.Delete Shift:=xlUp
Cells.Select
Cells.EntireColumn.AutoFit
linha = 1
While Cells(linha, 1).Value <> ""
Cells(linha, 1).Value = "'" & Cells(linha, 1).Value
linha = linha + 1
Wend
linha = 2
While Cells(linha, 9).Value <> ""
If CInt(Cells(linha, 9).Value) > 1 Or (Cells(linha, 3).Value <> "" And Cells(linha, 4).Value <> "") Then
Cells(linha, 2).Value = Cells(linha, 2).Value & " ("
If CInt(Cells(linha, 9).Value) > 1 Then Cells(linha, 2).Value = Cells(linha, 2).Value & "Qtd.: " & Cells(linha, 9).Value
For colVariacao = 3 To 7 Step 2
If (CInt(Cells(linha, 9).Value) > 1 And (Cells(linha, colVariacao).Value <> "" And Cells(linha, colVariacao + 1).Value <> "")) Or (colVariacao > 3 And Cells(linha, colVariacao).Value <> "") Then Cells(linha, 2).Value = Cells(linha, 2).Value & " / "
If Cells(linha, colVariacao).Value <> "" And Cells(linha, colVariacao + 1).Value <> "" Then Cells(linha, 2).Value = Cells(linha, 2).Value & Cells(linha, colVariacao).Value & ": " & Cells(linha, colVariacao + 1).Value
Next
Cells(linha, 2).Value = Cells(linha, 2).Value & ")"
End If
linha = linha + 1
Wend
Columns("C:H").Select
Selection.Delete Shift:=xlToLeft
linha = 1
linhaSort = 1
pedAtual = Cells(linha, 1).Value
While Cells(linha, 2).Value <> ""
If InStr(1, Cells(linha, 2).Value, "projeto", 1) > 0 Or InStr(1, Cells(linha, 2).Value, "projetos", 1) > 0 Then
Cells(linha, 3).Value = "1"
ElseIf InStr(1, Cells(linha, 2).Value, "kit completo", 1) > 0 Then
Cells(linha, 3).Value = "2"
ElseIf InStr(1, Cells(linha, 2).Value, "base mdf", 1) > 0 Then
Cells(linha, 3).Value = "4"
ElseIf InStr(1, Cells(linha, 2).Value, "rostinho", 1) > 0 Then
Cells(linha, 3).Value = "5"
Else
Cells(linha, 3).Value = "3"
End If
If pedAtual <> Cells(linha, 1).Value Then
pedAtual = Cells(linha, 1).Value
linhaSort = linhaSort + 1
End If
Cells(linha, 4).Value = linhaSort
linha = linha + 1
Wend
With ActiveWorkbook.ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add key:=Range("D1:D200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add key:=Range("C1:C200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:D200")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub
Sub PreparaEmpostagens()
'
' PreparaEmpostagens Macro
'
'
Sheets.Add After:=Sheets(2)
Sheets(3).Select
lc = 1
lf = 2
Sheets(3).Cells(1, 1).Value = "Pedido"
Sheets(3).Cells(1, 2).Value = "Codigo"
Sheets(3).Cells(1, 3).Value = "Nome"
Sheets(3).Cells(1, 4).Value = "CEP"
Sheets(3).Cells(1, 5).Value = "Frete"
While Trim(Sheets(1).Cells(lc, 8).Value) <> ""
CEPAtual = Trim(Sheets(1).Cells(lc, 8).Value)
lp = 1
While Trim(Sheets(2).Cells(lp, 21).Value) <> ""
If Trim(Sheets(2).Cells(lp, 21).Value) = CEPAtual Then
Sheets(3).Cells(lf, 1).Value = "'" & Sheets(2).Cells(lp, 1).Value
Sheets(3).Cells(lf, 2).Value = Sheets(1).Cells(lc, 1).Value
Sheets(3).Cells(lf, 3).Value = Sheets(2).Cells(lp, 28).Value
Sheets(3).Cells(lf, 4).Value = Sheets(1).Cells(lc, 8).Value
Sheets(3).Cells(lf, 5).Value = Sheets(2).Cells(lp, 9).Value
Sheets(3).Cells(lf, 6).Value = "[ """ & Sheets(2).Cells(lp, 1).Value & """, """ & Sheets(1).Cells(lc, 1).Value & """ ],"
lf = lf + 1
End If
lp = lp + 1
Wend
lc = lc + 1
Wend
Cells.Select
Cells.EntireColumn.AutoFit
End Sub
Raw
MD5Hash.vb
Option Explicit
Public Function MD5Hash( _
ByVal strText As String, ByVal upperCase As Boolean) _
As String
' Create and return MD5 signature from strText.
' Signature has a length of 32 characters.
'
' 2005-11-21. Cactus Data ApS, CPH.
Dim cMD5 As New clsMD5
Dim strSignature As String
' Calculate MD5 hash.
strSignature = cMD5.MD5(strText)
If upperCase = True Then strSignature = UCase(strSignature)
' Return MD5 signature.
MD5Hash = strSignature
Set cMD5 = Nothing
End Function
Public Function IsMD5( _
ByVal strText As String, _
ByVal strMD5 As String) _
As Boolean
' Checks if strMD5 is the MD5 signature of strText.
' Returns True if they match.
' Note: strText is case sensitive while strMD5 is not.
'
' 2005-11-21. Cactus Data ApS, CPH.
Dim booMatch As Boolean
booMatch = (StrComp(strMD5, MD5Hash(strText), vbTextCompare) = 0)
IsMD5 = booMatch
End Function
Public Function GeraSenha(tamanho As Integer) As String
Dim senha, carac As String
Dim chrInic, chrFim, I As Integer
Randomize
For I = 1 To tamanho
If Round(Rnd(1)) = 1 Then
chrInic = 48
chrFim = 57
Else
chrInic = 97
chrFim = 122
End If
carac = Int((chrFim - chrInic + 1) * Rnd) + chrInic
senha = senha & Chr(carac)
Next
GeraSenha = senha
End Function
Raw
Regex.vb
'---------------------------------------------------------------------------------------vv
' Procedure : RegEx
' Author : Mike
' Date : 9/1/2010
' Purpose : Perform a regular expression search on a string and return the first match
' or the null string if no matches are found.
' Usage : If Len(RegEx("\d{1,2}[/-]\d{1,2}[/-]\d{2,4}", txt)) = 0 Then MsgBox "No date in " & txt
' : TheDate = RegEx("\d{1,2}[/-]\d{1,2}[/-]\d{2,4}", txt)
' : CUSIP = Regex("[A-Za-z0-9]{8}[0-9]",txt)
'---------------------------------------------------------------------------------------
'^^
Function Regex(Pattern As String, TextToSearch As String) As String 'vv
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = False
.Pattern = Pattern
End With
Set REMatches = RE.Execute(TextToSearch)
If REMatches.Count > 0 Then
Regex = REMatches(0)
Else
Regex = vbNullString
End If
End Function '^^
'---------------------------------------------------------------------------------------
' Procedure : RegExReplace
' Author : Mike
' Date : 11/4/2010
' Purpose : Attempts to replace text in the TextToSearch with text and back references
' from the ReplacePattern for any matches found using SearchPattern.
' Notes - If no matches are found, TextToSearch is returned unaltered. To get
' specific info from a string, use RegExExtract instead.
' Usage : ?RegExReplace("(.*)(\d{3})[\)\s.-](\d{3})[\s.-](\d{4})(.*)", "My phone # is 570.555.1234.", "$1($2)$3-$4$5")
' My phone # is (570)555-1234.
'---------------------------------------------------------------------------------------
'
Function RegExReplace(SearchPattern As String, TextToSearch As String, ReplacePattern As String, _
Optional GlobalReplace As Boolean = True, _
Optional IgnoreCase As Boolean = False, _
Optional MultiLine As Boolean = False) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = MultiLine
.Global = GlobalReplace
.IgnoreCase = IgnoreCase
.Pattern = SearchPattern
End With
RegExReplace = RE.Replace(TextToSearch, ReplacePattern)
End Function
'---------------------------------------------------------------------------------------
' Procedure : RegExExtract
' Author : Mike
' Date : 11/4/2010
' Purpose : Extracts specific information from a string. Returns empty string if not found.
' Usage : ?RegExExtract("(.*)(\d{3})[\)\s.-](\d{3})[\s.-](\d{4})(.*)", "My phone # is 570.555.1234.", "$2$3$4")
' 5705551234
' ?RegExExtract("(.*)(\d{3})[\)\s.-](\d{3})[\s.-](\d{4})(.*)", "My name is Mike.", "$2$3$4")
'
' ?RegExReplace("(.*)(\d{3})[\)\s.-](\d{3})[\s.-](\d{4})(.*)", "My name is Mike.", "$2$3$4")
' My name is Mike.
'---------------------------------------------------------------------------------------
'
Function RegExExtract(SearchPattern As String, TextToSearch As String, PatternToExtract As String, _
Optional GlobalReplace As Boolean = True, _
Optional IgnoreCase As Boolean = False, _
Optional MultiLine As Boolean = False) As String
Dim MatchFound As Boolean
MatchFound = Len(Regex(SearchPattern, TextToSearch)) > 0
If MatchFound Then
RegExExtract = RegExReplace(SearchPattern, TextToSearch, PatternToExtract, _
GlobalReplace, IgnoreCase, MultiLine)
Else
RegExExtract = vbNullString
End If
End Function
Raw
UtilGeral.vb
Sub DivideEmCelulas()
linha = ActiveCell.Row
While Cells(linha, ActiveCell.Column).Value <> ""
proxCol = ActiveCell.Column + 1
conteudoDividido = Split(Cells(linha, ActiveCell.Column).Value, " ")
For I = 0 To UBound(conteudoDividido)
Cells(linha, proxCol) = conteudoDividido(I)
proxCol = proxCol + 1
Next
linha = linha + 1
Wend
End Sub
Sub JuntaCelulasEmUma()
colSaida = ActiveCell.Column
While Cells(ActiveCell.Row, colSaida) <> ""
colSaida = colSaida - 1
Wend
Dim conteudoDividido() As String
cnt = 0
For Each cell In Selection
ReDim Preserve conteudoDividido(cnt)
conteudoDividido(cnt) = cell.Value
cnt = cnt + 1
Next
Cells(ActiveCell.Row, colSaida).Value = Join(conteudoDividido, " ")
End Sub
Function GoogleTranslate(inLanguage, outLanguage, str) As String
' Tools Refrence Select Microsoft internet Control
Dim IE As Object, I As Long
Dim inputstring As String, outputstring As String, text_to_convert As String, result_data As String, CLEAN_DATA
Set IE = CreateObject("InternetExplorer.application")
' TO CHOOSE INPUT LANGUAGE
inputstring = inLanguage
' TO CHOOSE OUTPUT LANGUAGE
outputstring = outLanguage
text_to_convert = WorksheetFunction.EncodeURL(str)
'open website
UrlToGo = "https://translate.google.com/#" & inputstring & "/" & outputstring & "/" & text_to_convert
IE.Visible = False
IE.navigate UrlToGo
Do Until IE.ReadyState = 4
DoEvents
Loop
Application.Wait (Now + TimeValue("0:00:5"))
Do Until IE.Document.getElementById("result_box").innerHTML <> ""
DoEvents
Loop
TransContent = IE.Document.getElementById("result_box").innerHTML
NoClosingSpan = Replace(TransContent, "</span>", "", , , vbTextCompare)
CLEAN_DATA = Split(NoClosingSpan, "<")
For j = LBound(CLEAN_DATA) To UBound(CLEAN_DATA)
result_data = result_data & Right(CLEAN_DATA(j), Len(CLEAN_DATA(j)) - InStr(CLEAN_DATA(j), ">"))
Next
IE.Quit
GoogleTranslate = result_data
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment