My question is simple..
How do I convert a string like "445B986D2DD3B41852964ABA11408E82" to 445B9-86D2D-D3B41-85296-4ABA1-1408E82
It should be in the format '#####-#####-#####-#####-#####-############(the last matter does not matter)
Here is a method using MOD
Dim OldStr As String
OldStr = "445B986D2DD3B41852964ABA11408E82"
Dim NewStr As String
For i = 1 To Len(OldStr)
NewStr = NewStr & Mid(OldStr, i, 1)
If i Mod 5 = 0 Then
NewStr = NewStr & "-"
End If
Next
and using STEP
For i = 1 To Len(st) Step 5
ss = ss & Mid(st, i, 5) & "-"
Next
Why don't you just add the dashes:
s = Left(s, 5) + "-" + Mid(s, 6, 5) + "-" + Mid(s, 11, 5) + "-" + Mid(s, 16, 5) _
+ "-" + Mid(s, 21, 5) + "-" + Right(s, Len(s) - 25)
You may use Mid(), Left(), Right() functions and concatenate operator (&). E.g:
dim str
str = "12345678"
str = Left(str, 2) &"-"& Mid(str, 2, 2) & "-"& Mid(str, 4, 2) & "-"&Right(str, 2)
MsgBox str ' the output will be 12-34-56-78
you can use a maskedinput textbox with that mask, but the maxlenght is 64, or i can send a supertextbox made by me with a lot of improvements
Related
I am calculating accuracy from a word document by calculating the total number of changes made once track review is on. Incorrect use of punctuation is calculated as 1/4 mark, while for contextual or grammar errors a full 1 mark is deducted.
Right now all carriage returns are being calculated as 1 full mark. I want this either to be removed completely or can pass it along as 1/4 mark deduction. I am using the following for counting . ; and , as 1/4 mark deduction.
For Each myRevision In ActiveDocument.Revisions
myRevision.Range.Select
If myRevision.Type = wdRevisionInsert Then
lngRevisions = Len(Selection.Text)
For i = 1 To lngRevisions
If Mid(Selection.Text, i, 1) = "," Then
punct = punct + 1
Else
End If
If Mid(Selection.Text, i, 1) = "." Then
punct = punct + 1
Else
End If
If Mid(Selection.Text, i, 1) = ";" Then
punct = punct + 1
Else
End If
If Mid(Selection.Text, i, 1) = "" Then
punct = punct + 1
Else
End If
Next i
Count = Count + 1
Else
End If
Next
tCorrections = Count + punct * 0.25 - punct
Accuracy = ((tWords - tCorrections) / tWords) * 100
Accuracy = Round(Accuracy, 1)
Use an array of types names (aLabels) and a string of the types occurring in your data (sC) via a mapping (aMap) of types to counting slots for a flexible way to classify your string(s). As in this demo:
Option Explicit
Dim aLabels : aLabels = Split("Vowels Consants Digits Punctuations EOLs Unclassified")
ReDim aCounts(UBound(aLabels))
Dim sC : sC = "abce1,2." & vbCr
Dim aMap : aMap = Array(0, 1, 1, 0, 2, 3, 2, 3, 4)
Dim sD : sD = sC & "d" & sC & "bb111."
Dim p, i
For p = 1 To Len(sD)
i = Instr(sC, Mid(sD, p, 1))
If 0 = i Then
i = UBound(aLabels)
Else
i = aMap(i - 1)
End If
aCounts(i) = aCounts(i) + 1
Next
For i = 0 To UBound(aLabels)
WScript.Echo Right(" " & aCounts(i), 3), aLabels(i)
Next
output:
cscript 42505210.vbs
4 Vowels
6 Consants
7 Digits
5 Punctuations
2 EOLs
1 Unclassified
Based on such raw data (frequencies of types) you an add specials weights.
Update wrt comment:
As I said: Add weights after calculating the raw frequencies:
... as above ...
Dim nSum
' Std - all weights = 1
nSum = 0 : For Each i In aCounts : nSum = nSum + i : Next
WScript.Echo "all pigs are equal:", nSum
' No EOLs
nSum = 0 : For Each i In aCounts : nSum = nSum + i : Next : nSum = nSum - aCounts(4)
WScript.Echo "EOLs don't count:", nSum
nSum = 0 : aCounts(0) = aCounts(0) * 4 : For Each i In aCounts : nSum = nSum + i : Next
WScript.Echo "vowels count * 4:", nSum
additional output:
all pigs are equal: 25
EOLs don't count: 23
vowels count * 4: 37
I am trying to simulate the I/O of this website page
My Input sheet looks like this:
Now after taking the values from input sheet and arranging them in ascending order I got this in a temp worksheet :
This is what my results sheet looks like:
Now I have tried this after sorting process(didn't add code for sorting since it's not the problem):
Set rng = Union(wTime.Range("D6:D25"), wTime.Range("F6:F25"), wTime.Range("H6:H25"), wTime.Range("J6:J25"))
cnt1 = 1: cnt2 = 1: cnt3 = 1: cnt4 = 1
wTime.Range("A6:A25") = Empty 'Ticker
For i = 1 To 20
bckStroke(i) = wTemp.Range("A" & i + 1).Value
brstStroke(i) = wTemp.Range("C" & i + 1).Value
btrFly(i) = wTemp.Range("E" & i + 1).Value
frStyle(i) = wTemp.Range("G" & i + 1).Value
wTime.Range("A6:A25") = Empty
For Each cel In rng
If cel.Column = 4 And cel.Value = bckStroke(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt1 < 6 Then
wRes.Cells((cnt1 + 5 + (cnt1 - 1) * 2) - 1, 4) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt1 + 5 + (cnt1 - 1) * 2, 4) = bckStroke(i) 'Time
cnt1 = cnt1 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 6 And cel.Value = brstStroke(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt2 < 6 Then
wRes.Cells((cnt2 + 5 + (cnt2 - 1) * 2) - 1, 6) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt2 + 5 + (cnt2 - 1) * 2, 6) = brstStroke(i) 'Time
cnt2 = cnt2 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 8 And cel.Value = btrFly(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt3 < 6 Then
wRes.Cells((cnt3 + 5 + (cnt3 - 1) * 2) - 1, 8) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt3 + 5 + (cnt3 - 1) * 2, 8) = btrFly(i) 'Time
cnt3 = cnt3 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 10 And cel.Value = frStyle(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt4 < 6 Then
wRes.Cells((cnt4 + 5 + (cnt4 - 1) * 2) - 1, 10) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt4 + 5 + (cnt4 - 1) * 2, 10) = frStyle(i) 'Time
cnt4 = cnt4 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
Next cel
Next i
I just want to know the simplest logic to get the desired result after arranging them in ascending order (refer temp sheet) it should be easy but I can't seem to understand it.
Conditions that I know of for now:
Each team should have unique swimmers (i.e 4 Unique names in each team)
A swimmer can appear in other team as well if he has best time in other category as well. (E.g. Marcelo will appear in top 4 team since he has the best time in all 4 categories)
Teams with shortest time should be placed 1st in the list on result sheet. I think sorting in ascending order takes care of this it's matter of selecting right swimmer from the temp sheet list.
EDIT:
4. Relay Logic premise: Get all the combinations possible without 2 identical strings. And then sort them lowest to largest. I'd do the following: Get all the possible combinations and their sum with the following: *Combinations may still be buggy, since it may be variable to how many numbers you may have. This is just a guide to describe the process
Sub Combinations()
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long, o As Long, p As Long, q As Long
Dim CountComb As Long, lastrow As Long
Range("K2").Value = Now - 5
Application.ScreenUpdating = False
CountComb = 0: lastrow = 6
For i = 1 To 6: For j = 1 To 5
For k = 1 To 6: For l = 1 To 6
If Not (i = j Or i = k Or i = l Or j = k Or j = l Or k = l) Then
Range("K" & lastrow).Value = Range("A" & i).Value & "/" & _
Range("B" & j).Value & "/" & _
Range("C" & k).Value & "/" & _
Range("D" & l).Value
lastrow = lastrow + 1
CountComb = CountComb + 1
End If
Next: Next
Next: Next
Range("K1").Value = CountComb
Range("K3").Value = Now + 21
Application.ScreenUpdating = True
End Sub
Function TimeSum(Persons As String, Chr As String) As Double
Dim ArrayPersons() As String: ArrayPersons = Split(Persons, Chr)
Dim SumOfTime As Double
Dim ItemPerson As Variant
Dim NumberRoutines As Long: NumberRoutines = 2
Const SheetData = "Sheet1"
For Each ItemPerson In ArrayPersons
SumOfTime = Sheets(SheetData).Columns(NumberRoutines).Find(ItemPerson).Offset(0, -1).Value + SumOfTime
NumberRoutines = NumberRoutines + 2
Next ItemPerson
TimeSum = SumOfTime
End Function
Maybe you could define better the sub to do what you desire for, but, the last coding could guide you in the right path. In a second thought, you could get combinations in a dictionary instead.
[
[
I've been searching Google for awhile and on this site but I can't figure out what &HF7 means? Can someone please explain? Sorry if its a dumb question. I'm very new to this stuff...
Here is the code I'm studying.
Set WshShell = CreateObject("WScript.Shell")
Key = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
DigitalID = WshShell.RegRead(key & "DigitalProductId")
ProductName = "Product Name: " & WshShell.RegRead(Key & "ProductName") & vbNewLine
ProductID = "Product ID: " & WshShell.RegRead(Key & "ProductID") & vbNewLine
ProductKey = "Installed Key: " & ConvertToKey(DigitalID)
ProductID = ProductName & ProductID & ProductKey
If vbYes = MsgBox(ProductId & vblf & vblf & "Save to a file?", vbYesNo + vbQuestion, "Windows Key Information") then
Save ProductID
End if
Function ConvertToKey(Key)
Const KeyOffset = 52
isWin8 = (Key(66) \ 6) And 1
Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
i = 24
Chars = "BCDFGHJKMPQRTVWXY2346789"
Do
Cur = 0
X = 14
Do
Cur = Cur * 256
Cur = Key(X + KeyOffset) + Cur
Key(X + KeyOffset) = (Cur \ 24)
Cur = Cur Mod 24
X = X -1
Loop While X >= 0
i = i -1
KeyOutput = Mid(Chars, Cur + 1, 1) & KeyOutput
Last = Cur
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
a = Mid(KeyOutput, 1, 5)
b = Mid(KeyOutput, 6, 5)
c = Mid(KeyOutput, 11, 5)
d = Mid(KeyOutput, 16, 5)
e = Mid(KeyOutput, 21, 5)
ConvertToKey = a & "-" & b & "-" & c & "-" & d & "-" & e
End Function
Function Save(Data)
Const ForWRITING = 2
Const asASCII = 0
Dim fso, f, fName, ts
fName = "Windows Key.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateTextFile fName
Set f = fso.GetFile(fName)
Set f = f.OpenAsTextStream(ForWRITING, asASCII)
f.Writeline Data
f.Close
End Function
&HF7 is used as a mask here.
The byte in position 66 of the array Key is compared with the byte &HF7
Written in binary form &HF7 becomes 11110111. If you "And" the value of Key(66) with 11110111 then you'll get a new byte made up of all the bits in Key(66) except the bit in the 4th position from the right.
For example if Key(66) is 10101010 then 10101010 And 11110111 will be 10100010.
It's the number 247.
In VBScript, the &H prefix indicates a hexadecimal number, similar to the 0x prefix in C/C++. The number is F7, which is equivalent of the decimal value 247.
It's a public constant: http://www.vbforums.com/showthread.php?277384-VB-Key-COnsts
Typically used to detect modifier keys being held (ctrl, alt etc)
http://microsoft.public.word.vba.general.narkive.com/28vVYW5c/detect-modifier-keys-from-vba
That specific one is Public Const VK_CRSEL which I assume to be Ctrl select.
Can someone try wrap their brain around this one? I thought it was simply ensuring there were 2 bytes in hex byte and ensuring the values were between 0 -9 and A-F but no.
A snippet of a program that is for an infrared controller/blaster. This subroutine will send the actual signals (or other codes) out the serial port to the controller for it to finish the job.
Sample call:
SendCode ("04241001")
The VB6 code says:
Public Sub SendCode(ByVal strOut As String)
' ****************************
' This sub sends the hex codes
' ****************************
Dim numb1 As Integer, numb2 As Integer
Dim strRS As String
Dim i As Long
Dim newline(200) As String, outline(200) As String
Debug.Print "Sending IR - " & strOut
strRS = vbNullString
For i = 1 To Len(strOut)
newline(i) = Mid(strOut, i, 1)
Next
For i = 1 To Len(strOut) Step 2
If Asc(newline(i)) < 64 Then
numb1 = (Asc(newline(i)) - 48) * 16
strRS = strRS + Format(Hex(numb1 / 16), "0")
Else
numb1 = (Asc(newline(i)) - 55) * 16
strRS = strRS + Format(Hex(numb1 / 16), "0")
End If
If Asc(newline(i + 1)) < 64 Then
numb2 = (Asc(newline(i + 1)) - 48)
strRS = strRS + Format(Hex(numb2), "0")
Else
numb2 = (Asc(newline(i + 1)) - 55)
strRS = strRS + Format(Hex(numb2), "0")
End If
numb1 = numb1 + numb2
outline((i + 1) \ 2) = CByte(numb1)
strRS = strRS + " "
Next
With MSComm1
.RTSEnable = True
Sleep (20)
.OutBufferCount = 0
For i = 1 To (Len(strOut) / 2)
.Output = Chr(outline(i))
Next
Sleep (20)
.RTSEnable = False
End With
End Sub
The question is based around the second For/Next loop with Step 2 and the embedded IF statements. What is going on inside the loop?
numb1 and numb2
What is the purpose of this loop?
It converts a hex string into a binary byte string, then sends the binary byte string.
It also converts the binary bytes back into hex (strRS) so that you can check the conversion and the output. The check/debug string is not used for anything, but if you put a break point in there you can check the values.
I have a script that outputs a .bmp captcha image.
The image is built in hexadecimal, and converted to binary and sent to the browser via response.binaryWrite chrB(CByte(myHexImage)) (as an image mime type = bmp)
I want the option to move away from that (changing mime type, etc) and toward just sending something to the output like this:
data:image/jpeg;base64,/9j/4AAQSkZJRgABAQAAAQABAAD/2 ...
(except that my images are BMP)
Is there a quick and easy way to convert that hex or binary to base64 in vbscript? Here is a snippet of what I have implmented now as described above.
how can I change this so I output, to the screen, valid hex format (which i can then easily convert to base64) or base64 directly?
Dim sBmpEndLine, sBmpInfoHeader, sBmpHeader, sTmpHex
If (m_iBmpWidth Mod 4) <> 0 Then
sBmpEndLine = string((4 - (m_iBmpWidth Mod 4)) * 2, "0")
Else
sBmpEndLine = vbNullString
End If
sBmpInfoHeader = array("28000000", "00000000", "00000000", "0100", "0800", "00000000", "00000000", "120B0000", "120B0000", "00000000", "00000000")
sBmpInfoHeader(1) = formatHex(hex(m_iBmpWidth), 4, 0, True)
sBmpInfoHeader(2) = formatHex(hex(m_iBmpHeight), 4, 0, True)
sBmpInfoHeader(6) = formatHex(hex((m_iBmpHeight * m_iBmpWidth) + (m_iBmpHeight * (len(sBmpEndLine) / 2))), 4, 0, True)
sBmpInfoHeader(9) = formatHex(hex(len(m_sBmpColorMap) / 8), 4, 0, True)
sBmpInfoHeader(10) = sBmpInfoHeader(9)
sBmpHeader = array("424D", "00000000", "0000", "0000", "00000000")
sBmpHeader(1) = formatHex(hex((len(join(sBmpHeader, "")) / 2) + (len(join(sBmpInfoHeader, "")) / 2) + (len(m_sBmpColorMap) / 2) + (m_iBmpHeight * m_iBmpWidth) + (m_iBmpHeight * (len(sBmpEndLine) / 2))), 4, 0, True)
sBmpHeader(4) = formatHex(hex((len(join(sBmpHeader, "")) / 2) + (len(join(sBmpInfoHeader, "")) / 2) + (len(m_sBmpColorMap) / 2)), 4, 0, True)
sendHex(join(sBmpHeader, ""))
sendHex(join(sBmpInfoHeader, ""))
sendHex(m_sBmpColorMap)
For y = m_iBmpHeight To 1 Step -1
For x = 1 To m_iBmpWidth
sTmpHex = m_aBitmap(y, x)
If sTmpHex = vbNullString Then
sendHex(m_sBgColor)
Else
sendHex(sTmpHex)
End If
Next
sendHex(sBmpEndLine)
Next
Response.Flush
And here is the sendHex() function:
Private Sub sendHex(valHex)
Dim iCntHex
For iCntHex = 1 To len(valHex) Step 2
'Response.BinaryWrite chrB(CByte("&H" & mid(valHex, iCntHex, 2)))
response.Write "&H" & mid(valHex, iCntHex, 2)
Next
End Sub
The Microsoft.XMLDOM has built in converters for bin.base64 and bin.hex. I wrote functions that demonstrate how to use this:
Function TextToBinary(text, dataType)
Dim dom
Set dom = CreateObject("Microsoft.XMLDOM")
dom.loadXML("<HELLO/>")
dom.documentElement.nodeTypedValue = text
dom.documentElement.dataType = dataType
TextToBinary = dom.documentElement.nodeTypedValue
End Function
Function BinaryToText(binary, dataType)
Dim dom
Set dom = CreateObject("Microsoft.XMLDOM")
dom.loadXML("<HELLO/>")
dom.documentElement.dataType = dataType
dom.documentElement.nodeTypedValue = binary
dom.documentElement.removeAttribute("dt:dt")
BinaryToText = dom.documentElement.nodeTypedValue
End Function
Function HexToBase64(strHex)
HexToBase64 = BinaryToText(TextToBinary(strHex, "bin.hex"), "bin.base64")
End Function
Function Base64ToHex(strBase64)
Base64ToHex = BinaryToText(TextToBinary(strBase64, "bin.base64"), "bin.hex")
End Function
Here's an example of their usage:
MsgBox HexToBase64("41")
MsgBox Base64ToHex("QQ==")
Also look at the ADODB.Stream as a means of working with binary files. It'll work with these routines.
I was able to get this working. Here is how.
In sendHex, I removed the &H portion, and wrapped my string in hex():
Private Sub sendHex(valHex)
Dim iCntHex
For iCntHex = 1 To len(valHex) Step 2
If len( mid(valHex, iCntHex, 2)) = 1 Then
response.write "0"
end if
response.write mid(valHex, iCntHex, 2)
Next
End Sub
This results in a string output like this (in byte strings of 2 hexidecimal chars):
424d1e050000000000003e00000028000000340000001800000001000
I can then dump that proper hex string into a HEX to base64 function as follows (not written by me, but rather, by Richard Mueller - http://www.rlmueller.net/Base64.htm)
Function HexToBase64(strHex)
' Function to convert a hex string into a base64 encoded string.
' Constant B64 has global scope.
Dim lngValue, lngTemp, lngChar, intLen, k, j, strWord, str64, intTerm
intLen = Len(strHex)
' Pad with zeros to multiple of 3 bytes.
intTerm = intLen Mod 6
If (intTerm = 4) Then
strHex = strHex & "00"
intLen = intLen + 2
End If
If (intTerm = 2) Then
strHex = strHex & "0000"
intLen = intLen + 4
End If
' Parse into groups of 3 hex bytes.
j = 0
strWord = ""
HexToBase64 = ""
For k = 1 To intLen Step 2
j = j + 1
strWord = strWord & Mid(strHex, k, 2)
If (j = 3) Then
' Convert 3 8-bit bytes into 4 6-bit characters.
lngValue = CCur("&H" & strWord)
lngTemp = Fix(lngValue / 64)
lngChar = lngValue - (64 * lngTemp)
str64 = Mid(B64, lngChar + 1, 1)
lngValue = lngTemp
lngTemp = Fix(lngValue / 64)
lngChar = lngValue - (64 * lngTemp)
str64 = Mid(B64, lngChar + 1, 1) & str64
lngValue = lngTemp
lngTemp = Fix(lngValue / 64)
lngChar = lngValue - (64 * lngTemp)
str64 = Mid(B64, lngChar + 1, 1) & str64
str64 = Mid(B64, lngTemp + 1, 1) & str64
HexToBase64 = HexToBase64 & str64
j = 0
strWord = ""
End If
Next
' Account for padding.
If (intTerm = 4) Then
HexToBase64 = Left(HexToBase64, Len(HexToBase64) - 1) & "="
End If
If (intTerm = 2) Then
HexToBase64 = Left(HexToBase64, Len(HexToBase64) - 2) & "=="
End If
End Function
This converts the above to base64, and I can use the output like this (e.g. in a browser url bar) to view it as an image:
data:image/bmp;base64,Qk0eBQAAAAAAAD4AAAAo...