here is a script which convert string into hex code:
strString = "test"
strHex =""
For i=1 To Len(strString)
strHex = strHex & " " & Hex(Asc(Mid(strString,i,1)))
Next
strHex = Right(strHex,Len(strHex)-1)
WScript.Echo strHex
I want to do a reverse action which converts hex into string, is this possible using vbscript?
VBScript uses "&H" to mark numbers as hexadecimals. So
>> WScript.Echo Chr("&H" & "41")
>>
A
>>
demonstrates the strategy in principle. Demo code:
Option Explicit
Function s2a(s)
ReDim a(Len(s) - 1)
Dim i
For i = 0 To UBound(a)
a(i) = Mid(s, i + 1, 1)
Next
s2a = a
End Function
Function s2h(s)
Dim a : a = s2a(s)
Dim i
For i = 0 To UBound(a)
a(i) = Right(00 & Hex(Asc(a(i))), 2)
Next
s2h = Join(a)
End Function
Function h2s(h)
Dim a : a = Split(h)
Dim i
For i = 0 To UBound(a)
a(i) = Chr("&H" & a(i))
Next
h2s = Join(a, "")
End Function
Dim s : s = "test"
WScript.Echo 0, s
WScript.Echo 1, s2h(s)
WScript.Echo 2, h2s(s2h(s))
output:
0 test
1 74 65 73 74
2 test
Update wrt comment/unicode:
Use AscW/ChrW (VB ref) to deal with UTF 16.
Option Explicit
Function s2a(s)
ReDim a(Len(s) - 1)
Dim i
For i = 0 To UBound(a)
a(i) = Mid(s, i + 1, 1)
Next
s2a = a
End Function
Function s2h(s)
Dim a : a = s2a(s)
Dim i
For i = 0 To UBound(a)
a(i) = Right("0000" & Hex(AscW(a(i))), 4)
Next
s2h = Join(a)
End Function
Function h2s(h)
Dim a : a = Split(h)
Dim i
For i = 0 To UBound(a)
a(i) = ChrW("&H" & a(i))
Next
h2s = Join(a, "")
End Function
Dim s : s = "abcä" & ChrW("&H" & "d98a")
WScript.Echo 0, s
WScript.Echo 1, s2h(s)
WScript.Echo 2, h2s(s2h(s))
Related
I have written code for an array of numbers which prints out. I'm now writing code to split the array into even and off numbers. I've started off with an if statement to separate the numbers but i'm struggling to find a solution on how to do it. My code below is failing as it's unable to split the numbers.
Sub main()
a=Array(5,10,15,20)
for each x in a
Msgbox(x)
If MyArray(I) / 2 = MyArray(I)
List1.AddItem MyArray(I) ' Even Integers
Else
List2.AddItem MyArray(I) ' Odd Integers
End if
next
End Sub
As Lankymart suggests, the simplest approach would be to use Mod() and check if the remainder is 1 or 0, but you can also do it with the approach you seemed to be working towards:
If MyArray(index)/2 = Int(MyArray(index)/2) Then
' Even number
Else
' Odd number
End If
Mod() approach:
If MyArray(index) Mod 2 = 0 Then
' Even number
Else
' Odd number
End If
Here's a complete subroutine that demonstrates what you are trying to do:
Dim arr(4) As Integer
Dim arrEven() As Integer
Dim iEvenValues As Integer
Dim arrOdd() As Integer
Dim iOddValues As Integer
Dim iCounter As Integer
' Initialize array
arr(0) = 5
arr(1) = 10
arr(2) = 15
arr(3) = 20
For iCounter = 1 To UBound(arr)
If arr(iCounter - 1) Mod 2 = 0 Then
iEvenValues = iEvenValues + 1
ReDim Preserve arrEven(iEvenValues)
arrEven(iEvenValues - 1) = arr(iCounter - 1)
Else
iOddValues = iOddValues + 1
ReDim Preserve arrOdd(iOddValues)
arrOdd(iOddValues - 1) = arr(iCounter - 1)
End If
Next
Dim sValues As String
sValues = "Even values (" & iEvenValues & "):"
For iCounter = 1 To UBound(arrEven)
sValues = sValues & " " & arrEven(iCounter - 1)
Next
MsgBox sValues
sValues = "Odd values (" & iOddValues & "):"
For iCounter = 1 To UBound(arrOdd)
sValues = sValues & " " & arrOdd(iCounter - 1)
Next
MsgBox sValues
I would like to convert the below code to bat file and export only product key abc123-abc123-abc123-abc123.
Option Explicit
Dim objshell, path, DigitalID, Result
Set objshell = CreateObject("WScript.Shell")
' Set registry key path
path = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
' Registry key value
DigitalID = objshell.RegRead(path & "DigitalProductId")
Dim ProductName, ProductID, ProductKey, ProductData
' Get ProductName, ProductID, ProductKey
ProductName = "Product Name: " & objshell.RegRead(path & "ProductName")
ProductID = "Product ID: " & objshell.RegRead(path & "ProductID")
ProductKey = "Installed Key: " & ConvertToKey(DigitalID)
ProductData = ProductName & vbNewLine & ProductID & vbNewLine & ProductKey
'Show messbox if save to a file
If vbYes = MsgBox(ProductData & vbLf & vbLf & "Save to a file?", vbYesNo + vbQuestion, "BackUp Windows Key Information") Then
Save ProductData
End If
' Convert binary to chars
Function ConvertToKey(Key)
Const KeyOffset = 52
Dim isWin8, Maps, i, j, Current, KeyOutput, Last, keypart1, insert
' Check if OS is Windows 8
isWin8 = (Key(66) \ 6) And 1
Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
i = 24
Maps = "BCDFGHJKMPQRTVWXY2346789"
Do
Current = 0
j = 14
Do
Current = Current * 256
Current = Key(j + KeyOffset) + Current
Key(j + KeyOffset) = (Current \ 24)
Current = Current Mod 24
j = j - 1
Loop While j >= 0
i = i - 1
KeyOutput = Mid(Maps, Current + 1, 1) & KeyOutput
Last = Current
Loop While i >= 0
If (isWin8 = 1) Then
keypart1 = Mid(KeyOutput, 2, Last)
insert = "N"
KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
If Last = 0 Then KeyOutput = insert & KeyOutput
End If
ConvertToKey = Mid(KeyOutput, 1, 5) & "-" & Mid(KeyOutput, 6, 5) & "-" & Mid(KeyOutput, 11, 5) & "-" & Mid(KeyOutput, 16, 5) & "-" & Mid(KeyOutput, 21, 5)
End Function
' Save data to a file
Function Save(Data)
Dim fso, fName, txt, objshell, UserName
Set objshell = CreateObject("wscript.shell")
' Get current user name
UserName = objshell.ExpandEnvironmentStrings("%UserName%")
' Create a text file on desktop
fName = "C:\Users\" & UserName & "\Desktop\WindowsKeyInfo.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set txt = fso.CreateTextFile(fName)
txt.Writeline Data
txt.Close
End Function
I have no idea how to do it. I just want it extract the installed windows key to a files.
Im trying to use wmic get product key but it get blank and I suspect it is because it is not embedded to OEM chip, so I have to find the installed key.
Give a try with this code :
Option Explicit
DIM fso,NewsFile,WshShell,write2File
Set WshShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set write2File = fso.CreateTextFile(".\Key.txt", True)
write2File.WriteLine(ConvertToKey(WshShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId")))
write2File.Close
WshShell.run ".\Key.txt"
'**************************************************
Function ConvertToKey(Key)
Const KeyOffset = 52
Dim i,Chars,Cur,x,KeyOutput
i = 28
Chars = "BCDFGHJKMPQRTVWXY2346789"
Do
Cur = 0
x = 14
Do
Cur = Cur * 256
Cur = Key(x + KeyOffset) + Cur
Key(x + KeyOffset) = (Cur \ 24) And 255
Cur = Cur Mod 24
x = x -1
Loop While x >= 0
i = i -1
KeyOutput = Mid(Chars, Cur + 1, 1) & KeyOutput
If (((29 - i) Mod 6) = 0) And (i <> -1) Then
i = i -1
KeyOutput = "-" & KeyOutput
End If
Loop While i >= 0
ConvertToKey = KeyOutput
End Function
'**************************************************
I want to remove and insert spaces after every byte in a hex string.
E.g.: if the hex string is
str = "0F0D3E"
then I want to insert spaces after every byte to obtain
str = "0F 0D 3E"
and also the reverse (remove spaces from the string so the string becomes "0F0D3E" again).
A quick and naïve approach would be:
Option Explicit
Private Sub Form_Load()
Dim sSrc As String
Dim sTgt As String
sSrc = "0F0D3E"
sTgt = SpaceIt(sSrc)
Debug.Print sTgt
sSrc = UnspaceIt(sTgt)
Debug.Print sSrc
End Sub
Private Function SpaceIt(sSrc As String) As String
Dim i As Long
Dim asSrc() As String
ReDim asSrc(0 To Len(sSrc) \ 2 - 1) As String
For i = 0 To Len(sSrc) - 1 Step 2
asSrc(i \ 2) = Mid$(sSrc, i + 1, 2)
Next i
SpaceIt = Join(asSrc, " ")
End Function
Private Function UnspaceIt(sSrc As String) As String
UnspaceIt = Replace(sSrc, " ", "")
End Function
You can harness the power of the Mid$ statement and the Mid$ function and a little arithmetic to write a function to do this pretty flexibly and efficiently:
Private Function Spacify( _
ByVal Text As String, _
ByVal StrideIn As Long, _
ByVal StrideOut As Long, _
Optional ByVal RTrim As Boolean) As String
Dim OutLen As Long
Dim CopyLen As Long
Dim OutPos As Long
Dim InPos As Long
If StrideIn <= StrideOut Then
OutLen = (Len(Text) \ StrideIn) * StrideOut
If RTrim Then OutLen = OutLen - (StrideOut - StrideIn)
CopyLen = StrideIn
Else
OutLen = ((Len(Text) + (StrideIn - StrideOut)) \ StrideIn) * StrideOut
CopyLen = StrideOut
End If
Spacify = Space$(OutLen)
OutPos = 1
For InPos = 1 To Len(Text) Step StrideIn
Mid$(Spacify, OutPos) = Mid$(Text, InPos, CopyLen)
OutPos = OutPos + StrideOut
Next
End Function
Example:
Private Sub Main()
Dim S As String
S = "0f030d"
Debug.Print """"; S; """"
S = Spacify(S, 2, 3)
Debug.Print """"; S; """"
S = Spacify(S, 3, 2)
Debug.Print """"; S; """"
S = Spacify(S, 2, 3, True)
Debug.Print """"; S; """"; " trimmed"
S = Spacify(S, 3, 2)
Debug.Print """"; S; """"
Debug.Print
S = "abc"
Debug.Print """"; S; """"
S = Spacify(S, 1, 2)
Debug.Print """"; S; """"
S = Spacify(S, 2, 1)
Debug.Print """"; S; """"
S = Spacify(S, 1, 2, True)
Debug.Print """"; S; """"; " trimmed"
S = Spacify(S, 2, 1)
Debug.Print """"; S; """"
Stop
End Sub
Result:
"0f030d"
"0f 03 0d "
"0f030d"
"0f 03 0d" trimmed
"0f030d"
"abc"
"a b c "
"abc"
"a b c" trimmed
"abc"
Try this:
Private Sub Form_Load()
Dim str As String
Dim newstr As String
str = "0F0D3E"
newstr = AddSpaces(str)
str = Replace(newstr, " ", "")
End Sub
Private Function AddSpaces(s As String) As String
Dim i As Integer
For i = 1 To Len(s) Step 2
AddSpaces = AddSpaces & Mid$(s, i, 2) & " "
Next
AddSpaces = Trim(AddSpaces)
End Function
I use this function to decode UTF-8:
function DecodeUTF8(s)
dim i
dim c
dim n
i = 1
do while i <= len(s)
c = asc(mid(s,i,1))
if c and &H80 then
n = 1
do while i + n < len(s)
if (asc(mid(s,i+n,1)) and &HC0) <> &H80 then
exit do
end if
n = n + 1
loop
if n = 2 and ((c and &HE0) = &HC0) then
c = asc(mid(s,i+1,1)) + &H40 * (c and &H01)
else
c = 191
end if
s = left(s,i-1) + chr(c) + mid(s,i+n)
end if
i = i + 1
loop
DecodeUTF8 = s
end function
But there are some probles to decode that characters:
€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ
In that case
c=191-->c='¿'
I found some info related with this problem:
http://www.i18nqa.com/debug/utf8-debug.html
Do you know any function to decode correctly?
Public Function DecodeUTF8(s)
Set stmANSI = Server.CreateObject("ADODB.Stream")
s = s & ""
On Error Resume Next
With stmANSI
.Open
.Position = 0
.CharSet = "Windows-1252"
.WriteText s
.Position = 0
.CharSet = "UTF-8"
End With
DecodeUTF8 = stmANSI.ReadText
stmANSI.Close
If Err.number <> 0 Then
lib.logger.error "str.DecodeUTF8( " & s & " ): " & Err.Description
DecodeUTF8 = s
End If
On error Goto 0
End Function
I get the error:
Line: 23
Char: 4
Subscript out of range: 'numbers'
which is at: if numbers(i) = a then
I have made this in javascript and it works, but I need to convert it.
function info(numbers)
dim numbers2(99999)
numbers3 = ""
dim low
dim high
dim mean
dim halve
total = 0
dim spaces(99999)
dim a
dim b
dim i
dim c
dim whole
dim meadian
dim mode1
dim mode2
dim intResult
dim med
x = UBound(numbers)+1
For a=0 To 999999 Step 1
For i=0 To x Step 1
if numbers(i) = a then
c = numbers(i)
numbers2 = c
numbers3 = numbers3 + c + " "
low = numbers2(0)
high = a
total = total + c
end if
Next
Next
halve = UBound(numbers2)/2
whole = UBound(numbers2)
intResult = whole Mod 2
If intResult = 0 Then
halve = halve - 0.5
median = numbers2(halve)
med = true
Else
median = (numbers2(halve1)+numbers2(halve1-1))/2
med = false
End if
mean = total / UBound(numbers)
if med = true then
msgbox(numbers3 & chr(13) & chr(13) & "Lowest: " & low & chr(13) & "Highest: " & high & chr(13) & "Total: " & total & chr(13) & "Median: " & median & chr(13))
else
msgbox(numbers3 & chr(13) & chr(13) & "Lowest: " & low & chr(13) & "Highest: " & high & chr(13) & "Total: " & total & chr(13) & "Median: " & median & " -" & numbers2(halve1) & "x" & numbers2(halve1-1) & chr(13))
end if
end function
dim q(19,291,29)
info(q)
And also, how can I be able to put q in inside a inputbox?
Just ask if you want the javascript code.
If you're going to declare your variables (good idea for production code): use Option Explicit and declare all variables. Otherwise don't bother.
Variable declarations become a little more readable if you put them on one line (comma-separated):
Dim numbers2(99999), numbers3, low, high, mean, halve, total
Dim spaces(99999), ...
...
numbers3 = ""
total = 0
As #RogerRowland has mentioned, the line x = UBound(numbers)+1 will return an index 1 greater than the upper boundary of your array, so the loop
For i=0 To x Step 1
if numbers(i) = a then
...
end if
Next
will try to access an element outside the array in the last loop cycle. Better do it like this:
For i=0 To UBound(numbers)
If numbers(i) = a Then
...
End If
Next
Step 1 is the default, BTW, so it can be omitted.
The Type Mismatch error you got after fixing that is most likely because you declared numbers2 as a static array:
dim numbers2(99999)
but then assign a scalar to it inside the loop:
numbers2 = c
That line should probably be
numbers2(i) = c