I found a very good solution about extracting embedded files in word. But this solution fails at ExtractFile function with error "subscript out of range" when I extract file. exe or .txt
Please help me.
How to extract embedded Files from Word
Sub ExtractFile(ByVal A0, ByVal A1, ByVal A2, ByVal A3, ByVal A4, ByVal OleFN, ByVal Z0, ByVal Z1, ByVal Z2, ByVal Z3, ByVal Z4, ByVal Z5, ByVal TextFN, ByVal offset, ByVal length)
Dim i, j, nFile As Long
Dim L() As Byte
Dim B() As Byte
If Not FileOpen(OleFN, B) Then Exit Sub
For i = 0 To UBound(B) - 64
If IIf(A0 < 0, B(i) < A0 * -1, B(i) = A0) And IIf(A1 = 256, B(i + 1) > 0, B(i + 1) = A1) And IIf(A2 = 256, B(i + 2) > 0, B(i + 2) = A2) And IIf(A3 = 256, B(i + 3) > 0, B(i + 3) = A3) And IIf(A4 = 256, B(i + 4) > 0, B(i + 4) = A4) Then Exit For
Next
If Z0 < 257 Then
For j = UBound(B) - 16 To i - 64 Step -1
If IIf(Z0 = 256, B(j) > 0, B(j) = Z0) And IIf(Z1 = 256, B(j + 1) > 0, B(j + 1) = Z1) And IIf(Z2 = 256, B(j + 2) > 0, B(j + 2) = Z2) And B(j + 3) = Z3 And IIf(Z4 = 256, B(j + 4) > 0, B(j + 4) = Z4) And IIf(Z5 = 256, B(j + 5) > 0, B(j + 5) = Z5) Then Exit For
Next
Else
j = UBound(B)
End If
ReDim L(0 To j - i + length)
For j = 0 To IIf(UBound(L) + i + offset > UBound(B), UBound(L) + i - length, UBound(L))
L(j) = B(i + j + offset)
Next
nFile = FreeFile
Open TextFN For Binary Access Write As nFile
Put nFile, , L
Close nFile
End Sub
ReDim encountered an error with message: "subscript out of range"
Related
I am passing a url using a string from a cell in an excel workbook.
The string is : Ben & Jerry's 2017 Base PIC - 1.
The following is my code to pass the string in a url:
Dim targetUrl As String: targetUrl =
"https://catalina.my.salesforce.com/_ui/search/ui/UnifiedSearchResults?searchType=2&sen=aAh&str=" & i & "#!/initialViewMode=summary"
where 'i' is the string that is passed.
This is the url obtained in chrome :
https://catalina.my.salesforce.com/_ui/search/ui/UnifiedSearchResults?str=Ben+&+Jerry%27s+2017+Base+PIC+-+1+=&searchType=2&sen=aAh#!/fen=aAh&initialViewMode=detail&str=Ben
As you can see, the '&' isn't encoded and the search doesn't include any value after 'Ben'.
Could someone guide me on how to solve this issue? Thank you.
To encode the parameter:
Sub Test()
Dim url As String
url = "https://catalina.my.salesforce.com/_ui/search/ui/UnifiedSearchResults" _
& "?searchType=2" _
& "&sen=aAh" _
& "&str=" & EncodeURL("Ben & Jerry's 2017 Base PIC - 1") _
& "#!/initialViewMode=summary"
Debug.Print url
End Sub
Public Function EncodeURL(url As String) As String
Dim buffer As String, i As Long, c As Long, n As Long
buffer = String$(Len(url) * 12, "%")
For i = 1 To Len(url)
c = AscW(Mid$(url, i, 1)) And 65535
Select Case c
Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95 ' Unescaped 0-9A-Za-z-._ '
n = n + 1
Mid$(buffer, n) = ChrW(c)
Case Is <= 127 ' Escaped UTF-8 1 bytes U+0000 to U+007F '
n = n + 3
Mid$(buffer, n - 1) = Right$(Hex$(256 + c), 2)
Case Is <= 2047 ' Escaped UTF-8 2 bytes U+0080 to U+07FF '
n = n + 6
Mid$(buffer, n - 4) = Hex$(192 + (c \ 64))
Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
Case 55296 To 57343 ' Escaped UTF-8 4 bytes U+010000 to U+10FFFF '
i = i + 1
c = 65536 + (c Mod 1024) * 1024 + (AscW(Mid$(url, i, 1)) And 1023)
n = n + 12
Mid$(buffer, n - 10) = Hex$(240 + (c \ 262144))
Mid$(buffer, n - 7) = Hex$(128 + ((c \ 4096) Mod 64))
Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
Case Else ' Escaped UTF-8 3 bytes U+0800 to U+FFFF '
n = n + 9
Mid$(buffer, n - 7) = Hex$(224 + (c \ 4096))
Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
End Select
Next
EncodeURL = Left$(buffer, n)
End Function
this is a function to search for a byte pattern (in process memory) in an array of bytes.
where SearchFor is the array of bytes to look for. and SearchInis the array of bytes dumped by the ReadProcessMemory external function. this is also done using Wildcard "?".
problem is if the byte pattern length is less or equal to 32 it will search. else return intptr.zero. and im not sure why.
Private Function WildCard(ByVal SearchIn As Byte(), ByVal SearchFor As Byte()) As IntPtr
Dim l As Integer = 0, m = 0
Dim iEnd As Integer = SearchFor.Length
Dim sBytes As Integer() = New Integer(&H100 - 1) {}
Dim i As Integer
For i = 0 To iEnd - 1
If (SearchFor(i) = &H3F) Then
l = (l Or (CInt(1) << ((iEnd - i) - 1)))
End If
Next i
If (l <> 0) Then
Dim j As Integer
For j = 0 To sBytes.Length - 1
sBytes(j) = l
Next j
End If
l = 1
Dim index As Integer = (iEnd - 1)
Do While (index >= 0)
sBytes(SearchFor(index)) = (sBytes(SearchFor(index)) Or l)
index -= 1
l = (l << 1)
Loop
Do While (m <= (SearchIn.Length - SearchFor.Length))
l = (SearchFor.Length - 1)
Dim length As Integer = SearchFor.Length
Dim k As Integer = -1
Do While (k <> 0)
k = (k And sBytes(SearchIn((m + l))))
If (k <> 0) Then
If (l = 0) Then
Return New IntPtr(m)
End If
length = l
End If
l -= 1
k = (k << 1)
Loop
m = (m + length)
Loop
Return IntPtr.Zero
End Function
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 7 years ago.
Improve this question
Form 2 is to enter ladder base and its off set value and for snakes where the snake head is and skakes off set value.
Not able to figure out why its not working . When the values are entered to show simulation it show's up error sandl is private and the other one is the validation one .
Public Class Form2
Dim sandl(99) As Integer
Dim snakeshead As TextBox()
Dim snakesoffset As TextBox()
Dim ladderfoot As TextBox()
Dim ladderoffset As TextBox()
Dim rnd As Random = New Random
Sub initialise()
For i = 0 To 99
sandl(i) = 0 ' reset data
Next
End Sub
Sub snake()
snakeshead = {txthead1, txthead2, txthead3, txthead4, txthead5, txthead6, txthead7, txthead8, txthead9, txthead10}
snakesoffset = {txtoffset1, txtoffset2, txtoffset3, txtoffset4, txtoffset5, txtoffset6, txtoffset7, txtoffset8, txtoffset9, txtoffset10}
' SnakeHead(i).Text = (i + 81).ToString
' SnakeOffset(i).Text = "10" '(i + 10).ToString
For i As Integer = 0 To 9
While True
Dim base = rnd.Next(90) + 11
If sandl(base - 1) <> 0 Then
Continue While
End If
Dim offset = rnd.Next(20) + 10
If base - offset < 1 Then
Continue While
End If
snakeshead(i).Text = base.ToString
snakesoffset(i).Text = offset.ToString
sandl(base - 1) = -offset
Exit While
End While
Next
End Sub
Sub ladders()
ladderfoot = {txtladder1, txtladder2, txtladder3, txtladder4, txtladder5, txtladder6, txtladder7, txtladder8, txtladder9, txtladder10}
ladderoffset = {txtladderoffset1, txtladderoffset2, txtladderoffset3, txtladderoffset4, txtladderoffset5, txtladderoffset6, txtladderoffset7, txtladderoffset8, txtladderoffset9, txtladderoffset10}
'For i As Integer = 0 To 9
' LadderFoot(i).Text = (i + 11).ToString
' LadderOffset(i).Text = "10"
For i As Integer = 0 To 99
sandl(i) = 0 'reset data
Next
For i As Integer = 0 To 9
While True
Dim base = rnd.Next(90) + 1
If sandl(base - 1) <> 0 Then
Continue While
End If
Dim offset = rnd.Next(20) + 10
If base + offset > 100 Then
Continue While
End If
ladderfoot(i).Text = base.ToString
ladderoffset(i).Text = offset.ToString
sandl(base - 1) = offset
Exit While
End While
Next
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
For i As Integer = 0 To 99
sandl(i) = 0 'reset data
Next
Dim valid = Validate(ladderfoot, ladderoffset, +1, "Ladder")
If (valid) Then
valid = Validate(snakeshead, snakesoffset, -1, "Snake")
End If
If (valid) Then
'Form3 = New Form3
Form3.ShowDialog()
End If
End Sub
Private Function Validate(tbBase() As TextBox, tbOffset() As TextBox, delta As Integer, s As String) As Boolean
For i As Integer = 0 To 9
Dim base As Integer
If ((Not Integer.TryParse(tbBase(i).Text.Trim(), base)) OrElse (base < 1) OrElse (base > 100) OrElse (sandl(base - 1) <> 0)) Then
MessageBox.Show(s & (i + 1).ToString() & " base is invalid.")
tbBase(i).Select()
tbBase(i).SelectAll()
Return False
End If
base -= 1 'zero based
Dim offset As Integer
If ((Not Integer.TryParse(tbOffset(i).Text.Trim(), offset)) OrElse (offset < 10) OrElse (offset > 30) OrElse (base + offset * delta < 0) OrElse (base + offset * delta >= 100)) Then
MessageBox.Show(s & (i + 1).ToString() & " offset is invalid.")
tbOffset(i).Select()
tbOffset(i).SelectAll()
Return False
End If
sandl(base) = offset * delta 'write offset
Next
Return True
End Function
End Class
Public Class Form3
Enum EState
Dice
Move
Slide
Wait
Win
End Enum
Dim Fnt = New Font("Arial", 16)
Dim FntBig = New Font("Arial", 256)
Dim Frame As Integer = -1 'counter
Dim State = EState.Dice
Dim Rnd As Random = New Random
Dim Dice As Integer
Dim Pos As Point = New Point(32, 640 + 32)
Dim CurrentIndex As Integer = -1
Dim NextIndex As Integer
Dim TargetIndex As Integer
Private Sub Form3_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dice = 0
Frame = -1
State = EState.Dice
Pos = New Point(32, 640 + 32)
CurrentIndex = -1
End Sub
Private Sub PictureBox1_Paint(sender As Object, e As PaintEventArgs) Handles PictureBox1.Paint
DrawBackground(e.Graphics)
Frame += 1
Dim oldState = State
Select Case State
Case EState.Dice
If Frame = 0 Then
Dice = Rnd.Next(6) + 1 'roll dice
TargetIndex = CurrentIndex + Dice
NextIndex = CurrentIndex
ElseIf Frame >= 63 Then
If CurrentIndex + Dice < 100 Then
State = EState.Move 'valid dice
Else
State = EState.Wait 'invalid dice
End If
Dice = 0
End If
Case EState.Move
If Frame Mod 64 = 0 Then
CurrentIndex = NextIndex
If CurrentIndex = TargetIndex Then
If CurrentIndex < 99 Then 'not win
If Form2.sandl(CurrentIndex) <> 0 Then
State = EState.Slide 'snake or ladder
Else
State = EState.Dice 'empty tile
End If
TargetIndex = CurrentIndex + Form2.sandl(CurrentIndex)
Else
State = EState.Win 'win
End If
Else
NextIndex = CurrentIndex + 1 'move
End If
Else
Dim c = GetCoordinate(CurrentIndex)
Dim n = GetCoordinate(NextIndex)
Dim dx = (n.X - c.X)
Dim dy = (n.Y - c.Y)
Pos.X = c.X * 64 + (dx * (Frame Mod 64)) + 32
Pos.Y = c.Y * 64 + (dy * (Frame Mod 64)) + 32
End If
Case EState.Slide
If Frame >= 63 Then
CurrentIndex = TargetIndex
If CurrentIndex < 99 Then
State = EState.Dice 'not win
Else
State = EState.Win 'win
End If
Else
Dim c = GetCoordinate(CurrentIndex)
Dim n = GetCoordinate(TargetIndex)
Dim dx = (n.X - c.X)
Dim dy = (n.Y - c.Y)
Pos.X = c.X * 64 + (dx * (Frame Mod 64)) + 32
Pos.Y = c.Y * 64 + (dy * (Frame Mod 64)) + 32
End If
Case EState.Wait
If Frame >= 63 Then
State = EState.Dice
End If
End Select
e.Graphics.FillEllipse(Brushes.Blue, Pos.X - 16, Pos.Y - 16, 32, 32) 'draw player
If Dice > 0 Then
Dim size = e.Graphics.MeasureString(Dice.ToString, FntBig)
e.Graphics.DrawString(Dice.ToString, FntBig, Brushes.Black, 320 - size.Width / 2, 320 - size.Height / 2) 'print dice
End If
If State <> oldState Then
Frame = -1 'reset counter
End If
If State <> EState.Win Then
PictureBox1.Invalidate() 'schedule next paint
End If
End Sub
Private Sub DrawBackground(g As Graphics)
For y As Integer = 0 To 9
For x As Integer = 0 To 9
If (((x + y) Mod 2) = 0) Then
g.FillRectangle(Brushes.LightGray, x * 64, y * 64, 64, 64) 'dark rectangle
End If
Dim z = (9 - y) * 10 + x + 1
If y Mod 2 = 0 Then
z = (9 - y) * 10 + (9 - x) + 1
End If
g.DrawString(z.ToString, Fnt, Brushes.Black, x * 64, y * 64) 'number
Next
Next
For i As Integer = 0 To 99
If Form2.sandl(i) <> 0 Then
Dim base = GetCoordinate(i)
Dim offset = GetCoordinate(i + Form2.sandl(i))
If Form2.sandl(i) > 0 Then 'ladder
Dim delta = Math.Abs(base.X - offset.X) + 4
g.DrawLine(Pens.Green, base.X * 64 + 32 - delta, base.Y * 64 + 32, offset.X * 64 + 32 - delta, offset.Y * 64 + 32) 'left part
g.DrawLine(Pens.Green, base.X * 64 + 32 + delta, base.Y * 64 + 32, offset.X * 64 + 32 + delta, offset.Y * 64 + 32) 'right part
Else 'snake
g.DrawLine(Pens.Red, base.X * 64 + 32, base.Y * 64 + 32, offset.X * 64 + 32, offset.Y * 64 + 32) 'red line
End If
End If
Next
End Sub
Private Function GetCoordinate(i As Integer) As Point
Dim result As Point
result.Y = 9 - (i \ 10)
result.X = i Mod 10
If result.Y Mod 2 = 0 Then
result.X = 9 - result.X
End If
Return result
End Function
End Class
In Form2, change your declaration from
Dim sandl(99) As Integer
to
Public sandl(99) As Integer
This would allow Form3 to access your integer array
Rename your Validate method to something else, like ValidateTextBoxes, or if you intend to overload the base.Validate, then declare as
Private Overloads Function Validate
I have been trying to get a 2D grid going. It's for a game map.
Unfortunately, the grid is not as it should be. And I cannot figure out why.
Does anyone have an idea?
Imports Microsoft.DirectX
Imports Microsoft.DirectX.Direct3D
Public Class clsIsometric
'==================================
' SETTINGS
'==================================
Private tile_size As New Point(64, 64) 'Size of one tile in pixels
Private map_size As New Point(25, 25) 'Amount of tiles in total
Private gDevice As Device
Private bufVertex As VertexBuffer
Private bufIndex As IndexBuffer
Private gVertices() As CustomVertex.TransformedColored
Private gIndices() As Integer
'==================================
' CONSTRUCTOR
'==================================
Public Sub New(vDevice As Device)
gDevice = vDevice
End Sub
Public Sub dispose()
bufVertex.Dispose()
bufIndex.Dispose()
bufVertex = Nothing
bufIndex = Nothing
End Sub
'==================================
' RENDERING
'==================================
Public Sub buildMap()
' Recreate buffers to fit the map size
ReDim gVertices((map_size.X + 1) * (map_size.Y + 1)) ' x+1 * y+1
ReDim gIndices(map_size.X * map_size.Y * 6) ' x * y * 6
Dim k As Integer
For cX = 0 To map_size.X - 1 'Rows
For cY = 0 To map_size.Y - 1 'Columns
'VERTEX
k = cX * map_size.X + cY
gVertices(k) = New CustomVertex.TransformedColored(cX * tile_size.X, cY * tile_size.Y, 0, 1, Color.Blue.ToArgb)
Next cY
Next cX
Dim vertexPerCol As Integer = map_size.Y + 1
k = 0
For ccX = 0 To map_size.X - 1
For ccY = 0 To map_size.Y - 1
gIndices(k) = ccX * vertexPerCol + ccY ' 0
gIndices(k + 1) = (ccX + 1) * vertexPerCol + (ccY + 1) ' 1
gIndices(k + 2) = (ccX + 1) * vertexPerCol + ccY ' 2
gIndices(k + 3) = ccX * vertexPerCol + ccY ' 3
gIndices(k + 4) = ccX * vertexPerCol + (ccY + 1) ' 4
gIndices(k + 5) = (ccX + 1) * vertexPerCol + (ccY + 1) ' 5
k += 6 'Each tile has 6 indices. Increase for next tile
Next
Next
bufVertex = New VertexBuffer(GetType(CustomVertex.TransformedColored), gVertices.Length, gDevice, Usage.Dynamic Or Usage.WriteOnly, CustomVertex.TransformedColored.Format, Pool.Default)
bufIndex = New IndexBuffer(GetType(Integer), gIndices.Length, gDevice, Usage.WriteOnly, Pool.Default)
End Sub
Public Sub render()
'RENDER THE MAP
bufVertex.SetData(gVertices, 0, LockFlags.ReadOnly)
bufIndex.SetData(gIndices, 0, LockFlags.None)
gDevice.VertexFormat = CustomVertex.TransformedColored.Format
gDevice.SetStreamSource(0, bufVertex, 0)
gDevice.Indices = bufIndex
gDevice.DrawIndexedPrimitives(PrimitiveType.TriangleList, 0, 0, gVertices.Length, 0, CInt(gIndices.Length / 3))
End Sub
End Class
This should output a perfect square grid of 25 by 25 tiles. But the wireframe looks like:
http://i43.tinypic.com/2whf51c.jpg
Your loop which build the vertices seems to end too early, because you have n+1 vertices each row/column. It fills the array only to the forelast column, which leads to a shift in the vertices.
For cX = 0 To map_size.X 'Rows
For cY = 0 To map_size.Y 'Columns
'VERTEX
k = cX * (map_size.X + 1) + cY
gVertices(k) = New CustomVertex.TransformedColored(cX * tile_size.X, cY * tile_size.Y, 0, 1, Color.Blue.ToArgb)
Next cY
Next cX
I have been having some problems trying to decrypt the string returned back from SagePay.
I used their asp.net kit which included the encrypt and decrypt functions using base64 - sending the information to SagePay is not a problem but I am having a number of problems trying to descrypt the string.
Here is the function I am using to descypt:
Private Function base64Decode(ByVal strEncoded As String) As String
Dim iRealLength As Integer
Dim strReturn As String
Dim iBy4 As Integer
Dim iIndex As Integer
Dim iFirst As Integer
Dim iSecond As Integer
Dim iThird As Integer
Dim iFourth As Integer
If Len(strEncoded) = 0 Then
base64Decode = ""
Exit Function
End If
'** Base 64 encoded strings are right padded to 3 character multiples using = signs **
'** Work out the actual length of data without the padding here **
iRealLength = Len(strEncoded)
Do While Mid(strEncoded, iRealLength, 1) = "="
iRealLength = iRealLength - 1
Loop
'** Non standard extension to Base 64 decode to allow for + sign to space character substitution by **
'** some web servers. Base 64 expects a +, not a space, so convert vack to + if space is found **
Do While InStr(strEncoded, " ") <> 0
strEncoded = Left(strEncoded, InStr(strEncoded, " ") - 1) & "+" & Mid(strEncoded, InStr(strEncoded, " ") + 1)
Loop
strReturn = ""
'** Convert the base 64 4x6 byte values into 3x8 byte real values by reading 4 chars at a time **
iBy4 = (iRealLength \ 4) * 4
iIndex = 1
Do While iIndex <= iBy4
iFirst = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 0, 1)))
'iFirst = CType(System.Convert.ToByte(CType(Mid(strEncoded, iIndex + 0, 1), Char)), Integer)
iSecond = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 1, 1)))
'iSecond = CType(System.Convert.ToByte(CType(Mid(strEncoded, iIndex + 1, 1), Char)), Integer)
iThird = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 2, 1)))
'iThird = CType(System.Convert.ToByte(CType(Mid(strEncoded, iIndex + 2, 1), Char)), Integer)
iFourth = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 3, 1)))
'iFourth = CType(System.Convert.ToByte(CType(Mid(strEncoded, iIndex + 3, 1), Char)), Integer)
strReturn = strReturn + CType(System.Convert.ToChar(((iFirst * 4) And 255) + ((iSecond \ 16) And 3)), String) 'Chr(((iFirst * 4) And 255) + ((iSecond \ 16) And 3))
strReturn = strReturn + CType(System.Convert.ToChar(((iSecond * 16) And 255) + ((iThird \ 4) And 15)), String) 'Chr(((iSecond * 16) And 255) + ((iThird \ 4) And 15))
strReturn = strReturn + CType(System.Convert.ToChar(((iThird * 64) And 255) + (iFourth And 63)), String) 'Chr(((iThird * 64) And 255) + (iFourth And 63))
iIndex = iIndex + 4
Loop
'** For non multiples of 4 characters, handle the = padding **
If iIndex < iRealLength Then
iFirst = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 0, 1)))
iSecond = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 1, 1)))
strReturn = strReturn & Chr(((iFirst * 4) And 255) + ((iSecond \ 16) And 3))
If iRealLength Mod 4 = 3 Then
iThird = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 2, 1)))
strReturn = strReturn & Chr(((iSecond * 16) And 255) + ((iThird \ 4) And 15))
End If
End If
base64Decode = strReturn
End Function
I don't think the web server is trying to encode anything as there are no + symbols within the url string and I have just glanced over the two to compair they are the same.
This returns a blank string whereas when I use the sections commented out in the first loop i get a really weired string back and when I use their simpleXor function it just returns complete nonsense.
There support is a bit useless as they "are not programmers"! So I am hoping someone can help me out who has used SagePay before.
Thanks in advance.
Managed to get it working:
Private Function base64Decode(ByVal strEncoded As String) As String
Dim output As String = ""
Dim bt64 As Byte() = System.Convert.FromBase64String(strEncoded)
For i As Integer = 0 To (bt64.Length - 1)
output &= System.Convert.ToChar(CInt(bt64(i))).ToString()
Next
Return output
End Function