I have a project in VBA that does the base64 encoding and uploads the file (.xlsm).
VBA Code:
Option Explicit
Private Const clOneMask = 16515072 '000000 111111 111111 111111
Private Const clTwoMask = 258048 '111111 000000 111111 111111
Private Const clThreeMask = 4032 '111111 111111 000000 111111
Private Const clFourMask = 63 '111111 111111 111111 000000
Private Const clHighMask = 16711680 '11111111 00000000 00000000
Private Const clMidMask = 65280 '00000000 11111111 00000000
Private Const clLowMask = 255 '00000000 00000000 11111111
Private Const cl2Exp18 = 262144 '2 to the 18th power
Private Const cl2Exp12 = 4096 '2 to the 12th
Private Const cl2Exp6 = 64 '2 to the 6th
Private Const cl2Exp8 = 256 '2 to the 8th
Private Const cl2Exp16 = 65536 '2 to the 16th
Private cbTransTo(63) As Byte
Private cbTransFrom(255) As Byte
Private clPowers8(255) As Long
Private clPowers16(255) As Long
Private clPowers6(63) As Long
Private clPowers12(63) As Long
Private clPowers18(63) As Long
Private Sub Class_Initialize()
Dim lTemp As Long
For lTemp = 0 To 63 'Fill the translation table.
Select Case lTemp
Case 0 To 25
cbTransTo(lTemp) = 65 + lTemp 'A - Z
Case 26 To 51
cbTransTo(lTemp) = 71 + lTemp 'a - z
Case 52 To 61
cbTransTo(lTemp) = lTemp - 4 '1 - 0
Case 62
cbTransTo(lTemp) = 43 'Chr(43) = "+"
Case 63
cbTransTo(lTemp) = 47 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 255 'Fill the lookup tables.
clPowers8(lTemp) = lTemp * cl2Exp8
clPowers16(lTemp) = lTemp * cl2Exp16
Next lTemp
For lTemp = 0 To 63
clPowers6(lTemp) = lTemp * cl2Exp6
clPowers12(lTemp) = lTemp * cl2Exp12
clPowers18(lTemp) = lTemp * cl2Exp18
Next lTemp
For lTemp = 0 To 255 'Fill the translation table.
Select Case lTemp
Case 65 To 90
cbTransFrom(lTemp) = lTemp - 65 'A - Z
Case 97 To 122
cbTransFrom(lTemp) = lTemp - 71 'a - z
Case 48 To 57
cbTransFrom(lTemp) = lTemp + 4 '1 - 0
Case 43
cbTransFrom(lTemp) = 62 'Chr(43) = "+"
Case 47
cbTransFrom(lTemp) = 63 'Chr(47) = "/"
End Select
Next lTemp
End Sub
Public Function Encode(sString As String) As String
Dim bTrans(63) As Byte, bOut() As Byte, bIn() As Byte, lOutSize As Long
Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long
iPad = Len(sString) Mod 3 'See if the length is divisible by 3
If iPad Then 'If not, figure out the end pad and resize the input.
iPad = 3 - iPad
sString = sString & String(iPad, Chr(0))
End If
bIn = StrConv(sString, vbFromUnicode) 'Load the input string.
lLen = ((UBound(bIn) + 1) \ 3) * 4 'Length of resulting string.
lTemp = lLen \ 72 'Added space for vbCrLfs.
lOutSize = ((lTemp * 2) + lLen) - 1 'Calculate the size of the output buffer.
ReDim bOut(lOutSize) 'Make the output buffer.
lLen = 0 'Reusing this one, so reset it.
For lChar = LBound(bIn) To UBound(bIn) Step 3
lTrip = clPowers16(bIn(lChar)) + clPowers8(bIn(lChar + 1)) + bIn(lChar + 2) 'Combine the 3 bytes
lTemp = lTrip And clOneMask 'Mask for the first 6 bits
bOut(lPos) = cbTransTo(lTemp \ cl2Exp18) 'Shift it down to the low 6 bits and get the value
lTemp = lTrip And clTwoMask 'Mask for the second set.
bOut(lPos + 1) = cbTransTo(lTemp \ cl2Exp12) 'Shift it down and translate.
lTemp = lTrip And clThreeMask 'Mask for the third set.
bOut(lPos + 2) = cbTransTo(lTemp \ cl2Exp6) 'Shift it down and translate.
bOut(lPos + 3) = cbTransTo(lTrip And clFourMask) 'Mask for the low set.
If lLen = 68 Then 'Ready for a newline
bOut(lPos + 4) = 13 'Chr(13) = vbCr
bOut(lPos + 5) = 10 'Chr(10) = vbLf
lLen = 0 'Reset the counter
lPos = lPos + 6
Else
lLen = lLen + 4
lPos = lPos + 4
End If
Next lChar
If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.
If iPad = 1 Then 'Add the padding chars if any.
bOut(lOutSize) = 61 'Chr(61) = "="
ElseIf iPad = 2 Then
bOut(lOutSize) = 61
bOut(lOutSize - 1) = 61
End If
Encode = StrConv(bOut, vbUnicode) 'Convert back to a string and return it.
End Function
The generated output is exactly like this:
Required Output
I am trying to achieve the same output in VB.Net but I am unable to do so. I tried using the following:
Dim testStr As String = "test.xlsm"
Dim byt As Byte() = Encoding.Default.GetBytes(testStr)
testStr = Convert.ToBase64String(byt)
Input String: http://txt.do/obff
But I am not getting exactly the same string back. The first line is different in both cases (VBA and VB.Net) and I'm not sure why.
Required Output (VBA and the weblink):
UEsDBBQABgAIAAAAIQCsmTVRbwEAAD8EAAATAAgCW0NvbnRlbnRfVHlwZXNdLnhtbCCiBAIooAACAAAAAAAAAAAAAAAAAAAAAAAA
Generated Output (VB.Net):
UEsDBBQABgAIAAAAIQA/PzVRbwEAAD8EAAATAAgCW0NvbnRlbnRfVHlwZXNdLnhtbCA/BAIoPwACAAAAAAAAAAAAAAAAAAAAAAAAA
Could you please let me know where I am going wrong and how can I achieve the same in VB.Net?
I managed to solve the problem by getting the file directly, reading all its bytes and converting it to base64 string.
Dim dat As Byte() = IO.File.ReadAllBytes(FileName)
testStr = Convert.ToBase64String(dat, Base64FormattingOptions.InsertLineBreaks)
Related
I've written a script in VBA to create random terrain generation in excel, based on this following matlab script (http://knight.temple.edu/~lakamper/courses/cis350_2004/sources/matlabFractal/createFractalTerrain.m)
After compiling my script I found no bugs, but upon running in excel only cell A1 is assigned a value of zero, and then the script ends.
Now, I wondered if anyone had the time to look through my VBA script and see if they have any idea what's going wrong. I think maybe perhaps I mess around with an array called TR quite a bit when I could perhaps refer to the Cells directly from the get go.
Now, the code is bit long so I have provided a link to the text file that here, and so if nobody has the time I completely understand
https://www.dropbox.com/sh/c2l2ha0awirlowb/AAARGVpidQGP7I9Yu0XRN8yaa?dl=0
Also, here is the code indented.
Public TR(1 To 129, 1 To 129) As Double
Sub DiamondSquare()
Dim tsize As Long: tsize = 129
Dim StartRangRange As Double: startRandRange = 64.5
Dim H As Double: H = 0.9
Call createFractalTerrain(tsize, startRandRange, H)
End Sub
Function createFractalTerrain(ByVal tsize As Long, ByVal startRandRange As Double, ByVal H As Double) As Variant
'Function creates fractal terrain by midpoint displacement (diamond square algorithm)
'Output should be a tsize by tsize matrix
'tSize must be a (power of 2) + 1 ie 129
'startRandRange defines the overall elevation; size/2 gives natural images
'Roughness H (between 0 and 1); 0.9 is a natural value
'H=0 is max roughness
'Initiate Terrain
Dim i As Long
Dim j As Long
Dim ii As Long
Dim jj As Long
For i = 1 To tsize
For j = 1 To tsize
TR(i, j) = 10000
Next
Next
TR(1, 1) = 0
TR(1, tsize) = 0
TR(tsize, 1) = 0
TR(tsize, tsize) = 0
tsize = tsize - 1
randRange = startRandRange
'Main Loop
While tsize > 1
Call diamondStep(tsize, randRange)
Call squareStep(tsize, randRange)
tsize = tsize / 2
randRange = randRange * (1 / (2 ^ H))
Wend
For ii = 1 To tsize
For jj = 1 To tsize
Cells(ii, jj).Value = TR(ii, jj)
Next
Next
End Function
Sub diamondStep(ByVal tsize As Integer, ByVal randRange As Double)
sh = tsize / 2
maxIndex = UBound(TR, 1)
RowVal = 1 + sh
ColVal = 1 + sh
While RowVal < maxIndex
While ColVal < maxIndex
'Average height value of 4 cornerpoints
ValueH = TR(RowVal - sh, ColVal - sh) + TR(RowVal - sh, ColVal + sh) + TR(RowVal + sh, ColVal - sh) + TR(RowVal + sh, ColVal + sh)
ValueH = ValueH / 4
'Displacement
displacement = Int((1 - 0 + 1) * Rnd + 0) * randRange - randRange / 2
ValueH = ValueH + displacement
'Set diamond point
If TR(RowVal, ColVal) = 10000 Then TR(RowVal, ColVal) = ValueH
'Next square in same row
ColVal = ColVal + tsize
Wend
'Next row
ColVal = 1 + sh
RowVal = RowVal + tsize
Wend
End Sub
Sub squareStep(ByVal tsize As Integer, ByVal randRange As Double)
sh = tsize / 2
maxIndex = UBound(TR, 1)
colStart = 1 + sh
RowVal = 1
ColVal = colStart
While (RowVal <= maxIndex)
While (ColVal <= maxIndex)
ValueH = 0
nop = 4 'number of points
'the following cases handle the boundary points,
'i.e. the incomplete diamonds
'north
If RowVal > 1 Then
ValueH = ValueH + TR(RowVal - sh, ColVal)
Else
nop = nop - 1
End If
'east
If ColVal < maxIndex Then
ValueH = ValueH + TR(RowVal, ColVal + sh)
Else
nop = nop - 1
End If
'south
If RowVal < maxIndex Then
ValueH = ValueH + TR(RowVal + sh, ColVal)
Else
nop = nop - 1
End If
'west
If ColVal > 1 Then
ValueH = ValueH + TR(RowVal, ColVal - sh)
Else
nop = nop - 1
End If
'displacement
displacement = Int((1 - 0 + 1) * Rnd + 0) * randRange - randRange / 2
ValueH = ValueH / nop + displacement
'set square point (if not predefined)
If TR(RowVal, ColVal) = 10000 Then TR(RowVal, ColVal) = ValueH
'next diamond in same row
ColVal = ColVal + sh
Wend
'next row
'the starting column alternates between 1 and sh
If colStart = 1 Then
colStart = sh + 1
Else
colStart = 1
End If
ColVal = colStart
RowVal = RowVal + sh
Wend
End Sub
I think the issue you are experiencing is from not iterating over the array you created as you are resetting the tsize variable to 1.
Changing your code to something like this:
For ii = 1 To 129
For jj = 1 To 129
Cells(ii, jj).Value = TR(ii, jj)
Next
Next
Produces a grid of 129 Rows and 129 columns with numeric values. Alternatively you could use the LBound(TR) and UBound(TR) to achieve the same result as manually typing 1 to 129 in each of the For...Loop. I played around with this, and used a conditional format to color the cells based on their relative size either black or white. Here is the result, I think this is the type of output you are expecting.
I have to convert the following hex encoded string:
56 6f 6e 68 c3 b6 67 65 6e
The result should be: Vonhöger
However, the result I get is: Vonhöger
What is wrong with my code?
For x = 0 To hexString.Length - 1 Step 2
Dim k As String = hexString.Substring(x, 2)
If (k <> "X'") Then
com &= Chr(Val("&h" & k))
End If
Next
You are converting each byte to a unicode character, but the data is UTF-8 encoded, so some bytes in combination forms a character. The bytes c3 b6 is the code for the ö character.
Convert the data into bytes, then decode it as UTF-8:
Dim hexString = "566f6e68c3b667656e"
Dim bytes() As Byte
ReDim bytes(hexString.Length \ 2 - 1)
For i As Integer = 0 To bytes.Length - 1
bytes(i) = Convert.ToByte(hexString.Substring(i * 2, 2), 16)
Next
Dim com As String = Encoding.UTF8.GetString(bytes)
Similar to the other suggestions:
<Extension>
Public Function FromHexToUnicodeString(target As String) As String
Dim bytes((target.Length \ 2) - 1) As Byte
For b = 0 To bytes.Length - 1
bytes(b) = Convert.ToByte(target.Substring(b * 2, 2), 16)
Next
Return Text.Encoding.UTF8.GetString(bytes)
End Function
Usage:
MessageBox.Show("566f6e68c3b667656e".FromHexToUnicodeString)
This question already has answers here:
16 bit unsigned short byte flip in VB.NET
(2 answers)
Closed 8 years ago.
I need example in code, how to byte flip whole binary file. VB.NET
Example
02 00 0D 78 10 20 40 80 F1 F2 F4 F8 1F 2F 4F 8F
Flip Operation
00 02 78 0D 20 10 80 40 F2 F1 F8 F4 2F 1F 8F 4F
Whole, binary file using OpenFileDialog (OFD)
You just need to loop all items of the array and swap each bytes.
Dim bytes() As Byte = {&H2, &H0, &HD, &H78, &H10, &H20, &H40, &H80, &HF1, &HF2, &HF4, &HF8, &H1F, &H2F, &H4F, &H8F}
For i As Integer = 0 To bytes.Length - 1 Step 2
bytes(i) = bytes(i) Xor bytes(i + 1)
bytes(i + 1) = bytes(i + 1) Xor bytes(i)
bytes(i) = bytes(i) Xor bytes(i + 1)
Next
If you want, use a temp variable
For i As Integer = 0 To bytes.Length - 1 Step 2
Dim tempByte As Byte = bytes(i)
bytes(i) = bytes(i+1)
bytes(i + 1) = tempByte
Next
erm, you could write as you go, something like,
Dim file = dialog.FileName
Using output = New BinaryWriter(New FileStream( _
file, _
FileMode.Append, _
FileAccess.Write, _
FileShare.Read))
Using input = New BinaryReader(New FileStream( _
file, _
FileMode.Open, _
FileAccess.Read, _
FileShare.ReadWrite))
Dim bufferLength = 2
While bufferLength = 2
Dim buffer = input.ReadBytes(2)
bufferLength = buffer.Length
If bufferLength = 2 Then
output.Write(buffer(1))
output.Write(buffer(0))
Else If bufferLength = 1 Then
output.Write(buffer(0))
End If
End While
End Using
End Using
Here is my entire code and I will explain it and what I want to add.
The first function is calling two other functions.
The second function is used to calculate JMBG, which is unique number of citizen in my country. The third one is calculating PIB, which is registered number for companies.
Those two functions are OK and they don't need to be moved or anything like that.
We need to change this first function. As you can see, in the first function I am checking whether the length of the input string is OK. If the length is 13 numbers I call JMBG and if it is 8 I call PIB function. That is OK.
But I must check other types of validation in this first function. As I said, my Excel cell contains 13 numbers or 8 numbers. I want to make some rules in this first function that will tell me if my cell is filled with anything else except those 8 numbers or 13, then send me msg telling me that there is error in the cell and those 2 other functions then won't be called. As you can see, I need validation.
Example: Cell A1: 1234567891234...there is 13 numbers and JMBG will be called
08058808...there is 8 numbers and PIB will be called
1234567890123aSdf~...error because small and big letters and other characters are in the field.
As sum of all this, I need for 8 numbers to call PIB, for 13 numbers to call JMBG and for anything else except that to send me error.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ProvjeraID(ID As String) As String
If Len(ID) = 13 Then
ProvjeraID = Provjeri_JMBG(ID)
'Exit Function
ElseIf Len(ID) = 8 Then
ProvjeraID = ProvjeriPIB(ID)
'Exit Function
Else
ProvjeraID = "Duzina je razlicita od 8 i od 13"
'Exit Function
End If
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Provjeri_JMBG(JMBG As String) As String
' Funkcija vraca tekst sa opisom ispravnosti JMBG
' Primijeniti na radnom listu uz pomoc komande: =Proveri_JMBG(adresa)
' Inicijalizacija promenljivih koje se koriste prilikom izrade koda
Dim duzina As Integer, zbir As Integer
Dim cifra(1 To 13) As Integer
Dim dan As Integer, mesec As Integer, godina As String
' Inicijalizacija konstanti
Const ERR_dan = "GREŠKA: podatak o datumu neispravan!"
Const ERR_mesec = "GREŠKA: podatak o mesecu neispravan!"
Const ERR_godina = "GREŠKA: podatak o godini neispravan!"
Const ERR_duzina = "GREŠKA: dužina razlicita od 13!"
Const ERR_kont = "GREŠKA: neispravan kontrolni broj!"
Const OK_JMBG = "JMBG je ispravan"
' Preuzimanje ulaznih vrednosti sa kojima ce se vrsiti operacije
duzina = Len(JMBG)
dan = Int(Left(JMBG, 2))
mesec = Int(Mid$(JMBG, 3, 2))
godina = Mid$(JMBG, 5, 3)
' Provjera dužine JMBG
If (duzina <> 13) Then
Provjeri_JMBG = "GREŠKA: dužina razlicita od 13!"
Exit Function
End If
' Provjera datuma
If dan < 1 Then
Provjeri_JMBG = "GREŠKA: podatak o datumu neispravan!"
Exit Function
End If
' Provjera mjeseca i dana u mjesecu
Select Case mesec
Case 1, 3, 5, 7, 8, 10, 12
If dan > 31 Then
Provjeri_JMBG = "GREŠKA: podatak o datumu neispravan!"
Exit Function
End If
Case 4, 6, 9, 11
If dan > 30 Then
Provjeri_JMBG = "GREŠKA: podatak o datumu neispravan!"
Exit Function
End If
Case 2
If ((godina Mod 4 = 0) And dan > 29) Or _
((godina Mod 4 <> 0) And dan > 28) Then
Provjeri_JMBG = "GREŠKA: podatak o datumu neispravan!"
Exit Function
End If
Case Else
Provjeri_JMBG = "GREŠKA: podatak o mesecu neispravan!"
Exit Function
End Select
' Provjera godine: ispravne su od 1899 do tekuce godine
If (godina > Right(Str(Year(Now)), 3)) And (godina < "899") Then
Provjeri_JMBG = "GREŠKA: podatak o godini neispravan!"
Exit Function
End If
' Provjera kontrolnog broja
For i = 1 To 13
cifra(i) = Int(Mid$(JMBG, i, 1))
Next i
zbir = cifra(13) + cifra(1) * 7 + cifra(2) * 6
zbir = zbir + cifra(3) * 5 + cifra(4) * 4
zbir = zbir + cifra(5) * 3 + cifra(6) * 2
zbir = zbir + cifra(7) * 7 + cifra(8) * 6
zbir = zbir + cifra(9) * 5 + cifra(10) * 4
zbir = zbir + cifra(11) * 3 + cifra(12) * 2
If (zbir Mod 11) <> 0 Then
Provjeri_JMBG = "GREŠKA: neispravan kontrolni broj!"
Else
Provjeri_JMBG = "JMBG je ispravan"
End If
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function ProvjeriPIB(PIB As String)
Dim c0 As Integer
Dim c1 As Integer
Dim c2 As Integer
Dim c3 As Integer
Dim c4 As Integer
Dim c5 As Integer
Dim c6 As Integer
Dim c7 As Integer
Dim c8 As Integer
Dim zadnji As String
zadnji = Right(PIB, 1)
PIB = Left(PIB, 8)
If Len(PIB) <> 8 Then
ProvjeriPIB = "PIB je OK"
Else
c8 = (CInt(Mid(PIB, 1, 1)) + 10) Mod 10
If c8 = 0 Then
c8 = 10
End If
c8 = (c8 * 2) Mod 11
c7 = (CInt(Mid(PIB, 2, 1)) + c8) Mod 10
If c7 = 0 Then
c7 = 10
End If
c7 = (c7 * 2) Mod 11
c6 = (CInt(Mid(PIB, 3, 1)) + c7) Mod 10
If c6 = 0 Then
c6 = 10
End If
c6 = (c6 * 2) Mod 11
c5 = (CInt(Mid(PIB, 4, 1)) + c6) Mod 10
If c5 = 0 Then
c5 = 10
End If
c5 = (c5 * 2) Mod 11
c4 = (CInt(Mid(PIB, 5, 1)) + c5) Mod 10
If c4 = 0 Then
c4 = 10
End If
c4 = (c4 * 2) Mod 11
c3 = (CInt(Mid(PIB, 6, 1)) + c4) Mod 10
If c3 = 0 Then
c3 = 10
End If
c3 = (c3 * 2) Mod 11
c2 = (CInt(Mid(PIB, 7, 1)) + c3) Mod 10
If c2 = 0 Then
c2 = 10
End If
c2 = (c2 * 2) Mod 11
c1 = (CInt(Mid(PIB, 8, 1)) + c2) Mod 10
If c1 = 0 Then
c1 = 10
End If
c1 = (c1 * 2) Mod 11
c0 = (11 - c1) Mod 10
If c0 <> zadnji Then
ProvjeriPIB = "PIB je OK"
Else
ProvjeriPIB = "PIB nije OK"
End If
'return(pib || to_char(c0));
End If
End Function
This solution is based on regex from Scripting library. I have used 3 objects, but code definitely be trimmed to use just one object to check for all three conditions that you required. Since you wanted information about the text that you are inserting I have merely used 3 different regex rules.
Option Explicit
Sub TextNature()
Dim str As String
Dim strMsg As String
Dim objRegEx1 As Object, objRegEx2 As Object
Dim objRegEx3 As Object
str = Sheets(1).Range("A2").Value
'--check length
If Len(str) <> 13 Then
Exit Sub
strMsg = "Too lengthy...limit should be 13"
End If
Set objRegEx1 = CreateObject("VBScript.RegExp")
Set objRegEx2 = CreateObject("VBScript.RegExp")
Set objRegEx3 = CreateObject("VBScript.RegExp")
objRegEx1.IgnoreCase = False
objRegEx1.Global = True
objRegEx2.IgnoreCase = False
objRegEx2.Global = True
objRegEx3.IgnoreCase = False
objRegEx3.Global = True
objRegEx1.Pattern = "^\d+$" '-- only numbers
objRegEx2.Pattern = "^[a-zA-Z]+$" '-- only lower upper letters
objRegEx3.Pattern = "^[a-zA-Z\d]+$" '-- numbers and lower upper letters
If objRegEx1.Test(str) Then
strMsg = "Contain only numbers"
ElseIf objRegEx2.Test(str) Then
strMsg = "Contain only lower upper letters"
ElseIf objRegEx3.Test(str) Then
strMsg = "Contain numbers and lower upper letters"
Else
strMsg = "not satisfying"
End If
End Sub
Results : used the sub as a function:
OP requests for a function, and length limit to be 8:
Option Explicit
Function TextNature(ByRef rng As Range) As String
Dim str As String, strMsg As String
Dim objRegEx1 As Object, objRegEx2 As Object, objRegEx3 As Object
str = rng.Value
If Len(str) <> 8 Then
TextNature = "Limit is not correct. It should be 8."
Exit Function
End If
Set objRegEx1 = CreateObject("VBScript.RegExp")
Set objRegEx2 = CreateObject("VBScript.RegExp")
Set objRegEx3 = CreateObject("VBScript.RegExp")
objRegEx1.IgnoreCase = False
objRegEx1.Global = True
objRegEx2.IgnoreCase = False
objRegEx2.Global = True
objRegEx3.IgnoreCase = False
objRegEx3.Global = True
objRegEx1.Pattern = "^\d+$" '-- only numbers
objRegEx2.Pattern = "^[a-zA-Z]+$" '-- only lower/upper letters
objRegEx3.Pattern = "^[a-zA-Z\d]+$" '-- numbers and lower/upper letters
If objRegEx1.Test(str) Then
strMsg = "Contain only numbers"
ElseIf objRegEx2.Test(str) Then
strMsg = "Contain only lower upper letters"
ElseIf objRegEx3.Test(str) Then
strMsg = "Contain numbers and lower upper letters"
Else
strMsg = "Not Satisfying"
End If
TextNature = strMsg
End Function
Something like this should help - you can define the criteria in the select statement. It's a UDF so put the code into a module and enter =checkcell(A1) into a cell.
Public Function CheckCell(ByVal CheckRange As Range) As String
Dim strChr As String, rngCheck As Range
Dim i As Integer, NPC As Integer, UC As Integer, LC As Integer, OT As Integer
Set rngCheck = Range("A1")
For i = 1 To rngCheck.Characters.Count
strChr = rngCheck.Characters(i, 1).Text
Select Case Asc(strChr)
Case 0 To 31
NPC = NPC + 1
Case 96 To 122
LC = LC + 1
Case 65 To 90
UC = UC + 1
Case Else
OT = OT + 1
End Select
Next
CheckCell = "NPC: " & NPC & " UC: " & UC & " LC: " & LC & " Others: " & OT
End Function
In case formula-based solution is OK - use this ARRAY formula (assuming string for checking is in A1):
=IF(OR(NOT(ISERROR(SEARCH(ROW($1:$10)-1,A1)))),"Has digits","No digits")
and press CTRL+SHIFT+ENTER instead of usual ENTER - this will define an ARRAY formula and will result in {} brackets around it (but do NOT type them manually!).
String length and any other chars do not matter. Hope that was helpful)
Replace your first function with something like the following, and call it in a cell using =ProvjeraID2(A1) to evaluate the contents of cell A1:
Function ProvjeraID2(oRng As Range) As String
Dim sRet As String
If Not oRng Is Nothing Then
If IsNumeric(oRng.Value) Then
If Len(oRng.Value) = 13 Then
sRet = Provjeri_JMBG(CStr(oRng.Value))
ElseIf Len(oRng.Value) = 8 Then
sRet = ProvjeriPIB(CStr(oRng.Value))
Else
sRet = "Numeric but wrong length (" & Len(oRng.Value) & ")"
End If
Else
sRet = "Not a number"
End If
End If
ProvjeraID2 = sRet
End Function
I am looking for a simple way to encode an inputted text into Rot13. I am hitting a brick wall at the stage of being able to separate out words into individual characters and integers so that I can change each one and output the result. I can do it with single letters using a simple if statement listed bellow but if anyone can help with a way of doing it for whole words I would be very appreciative.
If kInput = "a" then kOutput = "n"
Thanks, Kai
Looks like people are giving good answers to this but here's my try at it.
Dim input As String = "This is a Test!! Guvf vf n Grfg!!"
Dim result As StringBuilder = New StringBuilder()
For Each ch As Char In input
If (Not Char.IsLetter(ch)) Then
result.Append(ch)
Continue For
End If
Dim checkIndex As Integer = Asc("a") - (Char.IsUpper(ch) * -32)
Dim index As Integer = ((Asc(ch) - checkIndex) + 13) Mod 26
result.Append(Chr(index + checkIndex))
Next
Console.WriteLine(result.ToString())
EDIT: improved to remove need for uppercase check. This will properly handle case and special characters with only 1 if statement inside the loop.
It seems like you're making this way harder than it has to be. No need to separate words, etc, and definitely no need for a large If/Else block:
Public Function Rot13(ByVal input As String) As String
Dim result As Char() = input.ToCharArray()
For i As Integer = 0 To result.Length - 1
Dim temp As Integer = Asc(result(i))
Select Case temp
Case 65 to 77, 97 To 109 'A - M
result(i) = Chr(temp + 13)
Case 78 to 90, 110 To 122 'N - Z
result(i) = Chr(temp - 13)
End Select
Next i
Return New String(result)
End Function
Note that this was entered directly into the browser window and is completely untested.
Just call it once to encode, call it again to decode.
Private Function ROT13_Encode(ByVal Input As String) As String
Dim chrs As Char() = Input.ToCharArray()
Dim ReturnString As String = ""
Dim CharInt As Integer
For Each Chr As Char In chrs
CharInt = Asc(Chr)
If CharInt >= 65 And CharInt <= 77 Then 'A-M
CharInt += 13
ElseIf CharInt >= 78 And CharInt <= 90 Then 'M-Z
CharInt -= 13
ElseIf CharInt >= 97 And CharInt <= 109 Then 'a-m
CharInt += 13
ElseIf CharInt >= 110 And CharInt <= 122 Then 'm-z
CharInt -= 13
End If
ReturnString &= ChrW(CharInt)
Next
Return ReturnString
End Function