I'm trying to convert to python-2.7 a VB6 process that extract data from Oracle BLOB.
This is the vb function that does the job:
Public Function ReadBlob(Optional sFieldName As Variant) As Variant
Dim sPar As String
Dim rsClone As New ADODB.Recordset
Dim aSingle() As Single
Dim aChunk() As Byte
Dim asByte() As sByte
Dim lChunkSize As Long
Dim lCount As Long
Dim lbCount As Long
Dim lSizeArray As Long
lChunkSize = 4
sFieldName = Trim$(sFieldName)
Set rsClone = m_recManagedObject.Clone
If IsMissing(sFieldName) Or sFieldName = vbNullString Then
For lCount = 0 To rsClone.Fields.Count
If rsClone.Fields(lCount).Attributes And adFldLong Then
sFieldName = rsClone.Fields(lCount).Name
Exit For
End If
Next
End If
lSize = rsClone.Fields(sFieldName).ActualSize
lSizeArray = lSize \ 4
If lSize > 0 Then
aChunk = rsClone.Fields(sFieldName).GetChunk(lSize)
Do While lbCount <= (lSizeArray * 4) - 1
ReDim Preserve asByte(lbCount)
CopyMemory asByte(lbCount).b1, ByVal VarPtr(aChunk(lbCount)), 1
CopyMemory asByte(lbCount).b2, ByVal VarPtr(aChunk(lbCount)) + 1, 1
CopyMemory asByte(lbCount).b3, ByVal VarPtr(aChunk(lbCount)) + 2, 1
CopyMemory asByte(lbCount).b4, ByVal VarPtr(aChunk(lbCount)) + 3, 1
lbCount = lbCount + 4
Loop
Erase aSingle
lCount = 0
For lbCount = 0 To (UBound(asByte)) Step 4
ReDim Preserve aSingle(lCount)
CopyMemory aSingle(lCount), asByte(lbCount), 4
lCount = lCount + 1
Next
Set rsClone = Nothing
End If
ReadBlob = aSingle
End Function
I get the BLOBs with JayDeBeApi (the source is an old Oracle version):
cn = jconn('DBSERVICE')
q = "select samples from mytable where id = 76472"
res = js (cn, q)
cn.close()
blob = res[0]['SAMPLES']
print(blob)
# output is oracle.sql.BLOB#475530b9
The content of this blobs is a sequence of float values.
Is there a python module that makes it easy to extract this sequence of values?
I have tried with blob(0.16) but I don't know if it is the right module nor how to use it.
UPDATE
I tried this:
blob = res[0]['SAMPLES'].getBinaryStream()
ByteArray = jpype.JArray(jpype.JByte)
j_buffer = ByteArray(1000000)
num_read = int(blob.read(j_buffer))
for i in range(0,num_read):
print(j_buffer[i])
"""
output is:
0
0
0
0
63
81
-10
66
-97
107
20
66
125
etc...
"""
this way I can read each single byte, I suppose, but I have to put together four bytes at a time to get a float.
Then I don't understand why there are negative values in the output.
Related
I am trying to read in a JPG file and convert the file to a base64 encoded string that can be used as an embedded jpeg on a web page. I found two functions on the web for base64 encoding/decoding in VBA that appear to be well-accepted. The encode/decode process yields my original binary string, so the functions appear to be at least somewhat correct. However the base64 string I am getting is no where near what I get when I use an online tool to convert my image to base64.
The base64 string should start: "/9j/4AAQSkZJRgABAQEAUgBSAAD". Instead it is starting with: "Pz8/Pz9BYT8/AD8/Pz8/Pz8/Pz8/Pz8/Pz8". I'm lost as to why I'm not getting the former result and why I'm getting the latter. Am I doing something wrong in my reading of the binary file?
Here is my code:
Sub TestBase64()
Dim bytes, b64
With CreateObject("ADODB.Stream")
.Open
.Type = ADODB.adTypeBinary
.LoadFromFile "c:\temp\TestPic.jpg"
bytes = .Read
.Close
End With
Debug.Print bytes
b64 = Base64Encode(bytes)
Debug.Print vbCrLf + vbCrLf
Debug.Print b64
Debug.Print vbCrLf + vbCrLf
Debug.Print Base64Decode(CStr(b64))
End Sub
' Decodes a base-64 encoded string (BSTR type).
' 1999 - 2004 Antonin Foller, http://www.motobit.com
' 1.01 - solves problem with Access And 'Compare Database' (InStr)
Function Base64Decode(ByVal base64String)
'rfc1521
'1999 Antonin Foller, Motobit Software, http://Motobit.cz
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim dataLength, sOut, groupBegin
'remove white spaces, If any
base64String = Replace(base64String, vbCrLf, "")
base64String = Replace(base64String, vbTab, "")
base64String = Replace(base64String, " ", "")
'The source must consists from groups with Len of 4 chars
dataLength = Len(base64String)
If dataLength Mod 4 <> 0 Then
Err.Raise 1, "Base64Decode", "Bad Base64 string."
Exit Function
End If
' Now decode each group:
For groupBegin = 1 To dataLength Step 4
Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
' Each data group encodes up To 3 actual bytes.
numDataBytes = 3
nGroup = 0
For CharCounter = 0 To 3
' Convert each character into 6 bits of data, And add it To
' an integer For temporary storage. If a character is a '=', there
' is one fewer data byte. (There can only be a maximum of 2 '=' In
' the whole string.)
thisChar = Mid(base64String, groupBegin + CharCounter, 1)
If thisChar = "=" Then
numDataBytes = numDataBytes - 1
thisData = 0
Else
thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
End If
If thisData = -1 Then
Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
Exit Function
End If
nGroup = 64 * nGroup + thisData
Next
'Hex splits the long To 6 groups with 4 bits
nGroup = Hex(nGroup)
'Add leading zeros
nGroup = String(6 - Len(nGroup), "0") & nGroup
'Convert the 3 byte hex integer (6 chars) To 3 characters
pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _
Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _
Chr(CByte("&H" & Mid(nGroup, 5, 2)))
'add numDataBytes characters To out string
sOut = sOut & Left(pOut, numDataBytes)
Next
Base64Decode = sOut
End Function
Function Base64Encode(inData)
'rfc1521
'2001 Antonin Foller, Motobit Software, http://Motobit.cz
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim cOut, sOut, i
'For each group of 3 bytes
For i = 1 To Len(inData) Step 3
Dim nGroup, pOut, sGroup
'Create one long from this 3 bytes.
nGroup = &H10000 * Asc(Mid(inData, i, 1)) + _
&H100 * MyASC(Mid(inData, i + 1, 1)) + MyASC(Mid(inData, i + 2, 1))
'Oct splits the long To 8 groups with 3 bits
nGroup = Oct(nGroup)
'Add leading zeros
nGroup = String(8 - Len(nGroup), "0") & nGroup
'Convert To base64
pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)
'Add the part To OutPut string
sOut = sOut + pOut
'Add a new line For Each 76 chars In dest (76*3/4 = 57)
'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
Next
Select Case Len(inData) Mod 3
Case 1: '8 bit final
sOut = Left(sOut, Len(sOut) - 2) + "=="
Case 2: '16 bit final
sOut = Left(sOut, Len(sOut) - 1) + "="
End Select
Base64Encode = sOut
End Function
Function MyASC(OneChar)
If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function
That's some lengthy way to encode. I prefer this:
You Need to add reference to Microsoft XML, v6.0 (or v3.0)
Sub TestBase64()
Dim bytes, b64
With CreateObject("ADODB.Stream")
.Open
.Type = ADODB.adTypeBinary
.LoadFromFile "c:\temp\TestPic.jpeg"
bytes = .Read
.Close
End With
Debug.Print bytes
b64 = EncodeBase64(bytes)
Debug.Print vbCrLf + vbCrLf
Debug.Print Left(b64, 100)
' Debug.Print vbCrLf + vbCrLf
' Debug.Print Base64Decode(CStr(b64))
End Sub
Private Function EncodeBase64(bytes) As String
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = bytes
EncodeBase64 = objNode.Text
Set objNode = Nothing
Set objXML = Nothing
End Function
Output (first few characters): /9j/4AAQSkZJRgABAQEAYABgAAD
How to Convert string in to Byte array that contain &H81 in first index if the byte array mybyte(0) with
i need to check in my byte array
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Sub cmdCommand1_Click()
Dim str As String
Dim BT() As Byte
BT() = StrToByte(tbMsg.Text)
If BT(0) = &H81 Then
'MyCode
End If
End Sub
the If mybyte(0) = &H81 Then condition is allays getting false
and currently i'm using this string to byte converting method
Public Function StrToByte(strInput As String) As Byte()
Dim lPntr As Long
Dim bTmp() As Byte
Dim bArray() As Byte
If Len(strInput) = 0 Then Exit Function
ReDim bTmp(LenB(strInput) - 1) 'Memory length
ReDim bArray(Len(strInput) - 1) 'String length
CopyMemory bTmp(0), ByVal StrPtr(strInput), LenB(strInput)
For lPntr = 0 To UBound(bArray)
If bTmp(lPntr * 2 + 1) > 0 Then
bArray(lPntr) = Asc(Mid$(strInput, lPntr + 1, 1))
Else
bArray(lPntr) = bTmp(lPntr * 2)
End If
Next lPntr
StrToByte = bArray
End Function
A typo I think, it should be:
If BT(0) = &H81 Then
Not
If mybyte(0) = &H81 Then
Your code seems to be converting the double byte unicode string into a single byte representation of the string, this will result in garbage for any character with a codepoint > 255.
If thats ok your code is equivalent to the built in:
BT() = StrConv(strInput, vbFromUnicode)
I have a flexgrid with a grouping, and a .subtotal by that grouping. All columns except one are numeric, the one that isn't is in the format 'x/y' e.g. '1/5', i.e. 1 out of 5 items supplied.
if I do a .Subtotal with a flexSTSum it sums up the first number in the pair, i.e. in the above example it would sum up the 1 as a decimal and show 1.00 in the subtotal row
At first I tried to find a way to sum on another column, i.e. I could put individual values into separate columns, give them a .Width of 0 and sum these into the .Subtotal column of the first column, but I can't find a way to do that.
And even if I do find a way to do that I want to be able to custom format the .Subtotal, so it appears as '3/17', i.e. '1/5' and '2/12' subtotal to '3/17' in the subtotal row.
if I can't subtotal off another column I wondered if I could custom access the subtotal row and manually enter the subtotal value of '3/17', but even that seems unavailable.
My question is, is there a way to achieve this?
I assume you are using the VideoSoft FlexGrid which i never used, so I can't help you with the specific methods of that control.
You can do it easily with a standard MSFlexGrid control though, and you can probably do the same with the VideoSoft FlexGrid.
Have a look at the following sample project:
'1 form with :
' 1 msflexgrid control : name=MSFlexGrid1
Option Explicit
Private Sub Form_Load()
Dim lngRow As Long, lngCol As Long
With MSFlexGrid1
.Rows = 10
.Cols = 4
.FixedRows = 0
.FixedCols = 0
For lngRow = 0 To .Rows - 2
For lngCol = 0 To .Cols - 2
.TextMatrix(lngRow, lngCol) = CStr(100 * lngRow + lngCol)
Next lngCol
.TextMatrix(lngRow, .Cols - 1) = CStr(lngRow) & "/" & CStr(lngRow * lngRow)
Next lngRow
End With 'MSFlexGrid1
End Sub
Private Sub Form_Resize()
MSFlexGrid1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub MSFlexGrid1_Click()
Dim lngCol As Long
'calculate subtotals
With MSFlexGrid1
For lngCol = 0 To .Cols - 2
.TextMatrix(.Rows - 1, lngCol) = CStr(GetTotal(lngCol))
Next lngCol
.TextMatrix(.Rows - 1, .Cols - 1) = GetTotalSpecial(.Cols - 1)
End With 'MSFlexGrid1
End Sub
Private Function GetTotal(lngCol As Long) As Long
Dim lngRow As Long
Dim lngTotal As Long
With MSFlexGrid1
lngTotal = 0
For lngRow = 0 To .Rows - 2
lngTotal = lngTotal + Val(.TextMatrix(lngRow, lngCol))
Next lngRow
End With 'MSFlexGrid1
GetTotal = lngTotal
End Function
Private Function GetTotalSpecial(lngCol As Long) As String
Dim lngRow As Long
Dim lngTotal1 As Long, lngTotal2 As Long
Dim strPart() As String
With MSFlexGrid1
lngTotal1 = 0
lngTotal2 = 0
For lngRow = 0 To .Rows - 2
strPart = Split(.TextMatrix(lngRow, .Cols - 1), "/")
If UBound(strPart) = 1 Then
lngTotal1 = lngTotal1 + Val(strPart(0))
lngTotal2 = lngTotal2 + Val(strPart(1))
End If
Next lngRow
End With 'MSFlexGrid1
GetTotalSpecial = CStr(lngTotal1) & "/" & CStr(lngTotal2)
End Function
It will load a grid with some values, and when you click on the grid, the subtotals will be calculated and filled into the last row.
I'm extremely unfamiliar with VB6 so please excuse the rookie question:
I'm attempting to turn a long into it's component bytes. In C it is simple because of the automatic truncation and the bitshift operators. For the life of me I cannot figure out how to do this in VB6.
Attempts so far have all generally looked something like this
sys1 = CByte(((sys & &HFF000000) / 16777216)) ' >> 24
sys2 = CByte(((sys & &HFF0000) / 65536)) ' >> 16
sys1 and sys2 are declared as Byte and sys is declared as Long
I'm getting a type mismatch exception when I try to do this. Anybody know how to convert a Long into 4 Bytes ??
Thanks
You divide correctly, but you forgot to mask out only the least significant bits.
Supply the word you want to divide into bytes, and the index (0 is least significant, 1 is next, etc.)
Private Function getByte(word As Long, index As Integer) As Byte
Dim lTemp As Long
' shift the desired bits to the 8 least significant
lTemp = word / (2 ^ (index * 8))
' perform a bit-mask to keep only the 8 least significant
lTemp = lTemp And 255
getByte = lTemp
End Function
Found on FreeVBCode.com. Not tested, sorry.
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal _
Length As Long)
Public Function LongToByteArray(ByVal lng as Long) as Byte()
'Example:
'dim bytArr() as Byte
'dim iCtr as Integer
'bytArr = LongToByteArray(90121)
'For iCtr = 0 to Ubound(bytArr)
'Debug.Print bytArr(iCtr)
'Next
'******************************************
Dim ByteArray(0 to 3)as Byte
CopyMemory ByteArray(0), Byval VarPtr(Lng),Len(Lng)
LongToByteArray = ByteArray
End Function
You can convert between simple value types and Byte arrays by combining UDTs and the LSet statement.
Option Explicit
Private Type DataBytes
Bytes(3) As Byte
End Type
Private Type DataLong
Long As Long
End Type
Private DB As DataBytes
Private DL As DataLong
Private Sub cmdBytesToLong_Click()
Dim I As Integer
For I = 0 To 3
DB.Bytes(I) = CByte("&H" & txtBytes(I).Text)
Next
LSet DL = DB
txtLong.Text = CStr(DL.Long)
txtBytes(0).SetFocus
End Sub
Private Sub cmdLongToBytes_Click()
Dim I As Integer
DL.Long = CLng(txtLong.Text)
LSet DB = DL
For I = 0 To 3
txtBytes(I).Text = Right$("0" & Hex$(DB.Bytes(I)), 2)
Next
txtLong.SetFocus
End Sub
I have a list of items in an Excel worksheet, A1-B115. At the moment I can enter 10 variables which retrieves the correct data from the list.
Code now:
C1=1 - run through A1-A115 and check for the value to be between 1000-2000; if so, copy the B value somewhere.
C2=1 - run through A1-A115 and check for the value to be between 2001-3000; if so, copy the B value somewhere.
....
What I would like to do is that I can enter a value (example: 25 or 30) and that my macro randomly selects the right amount of values.
Code I would like to do: C1: 30 -> randomly selects 30 values from B1-B115
This will do the trick.
Sub PickRandomItemsFromList()
Const nItemsToPick As Long = 10
Const nItemsTotal As Long = 115
Dim rngList As Range
Dim varRandomItems() As Variant
Dim i As Long
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
varRandomItems(i) = rngList.Cells(Int(nItemsTotal * Rnd + 1), 1)
Next i
' varRandomItems now contains nItemsToPick random items from range rngList.
End Sub
As discussed in the comments, this will allow individual items to be picked more than once within the nItemsToPick picked, if for example number 63 happens to be randomly picked twice. If you don't want this to happen, then an additional loop will have to be added to check whether the item about to be picked is already in the list, for example like so:
Sub PickRandomItemsFromList()
Const nItemsToPick As Long = 10
Const nItemsTotal As Long = 115
Dim rngList As Range
Dim idx() As Long
Dim varRandomItems() As Variant
Dim i As Long
Dim j As Long
Dim booIndexIsUnique As Boolean
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
Do
booIndexIsUnique = True ' Innoncent until proven guilty
idx(i) = Int(nItemsTotal * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then
' It's already there.
booIndexIsUnique = False
Exit For
End If
Next j
If booIndexIsUnique = True Then
Exit Do
End If
Loop
varRandomItems(i) = rngList.Cells(idx(i), 1)
Next i
' varRandomItems now contains nItemsToPick unique random
' items from range rngList.
End Sub
Note that this will loop forever if nItemsToPick > nItemsTotal !
I would use a collection to make sure you don't get any duplicates.
Function cItemsToPick(NrOfItems As Long, NrToPick As Long) As Collection
Dim cItemsTotal As New Collection
Dim K As Long
Dim I As Long
Set cItemsToPick = New Collection
If NrToPick > NrOfItems Then Exit Function
For I = 1 To NrOfItems
cItemsTotal.Add I
Next I
For I = 1 To NrToPick
K = Int(cItemsTotal.Count * Rnd + 1)
cItemsToPick.Add cItemsTotal(K)
cItemsTotal.Remove (K)
Next I
Set cItemsTotal = Nothing
End Function
You can test this function with the following code:
Sub test()
Dim c As New Collection
Dim I As Long
Set c = cItemsToPick(240, 10)
For I = 1 To c.Count
Debug.Print c(I)
Next I
End Sub