POS Printing with an Epson Printer in VB.NET - vb.net

I'm working in VB.NET and having some issues with a POS Printer I just connected (Epson TM-T88V). I recently downloaded a sample code from something I found on YouTube that used an Epson TM-88II, an older model of the V. This code would work perfectly fine if I could just open the serial port! What's happening is that the printer is on port USB-001 (the virtual printer port) and you can't just set that as your COM Port in VB to write to it. I downloaded the Microsoft POS for .NET and the OPOSN from Epson. The only question I have so far is where do I even start? Can anyone help me with connecting to the printer with VB and then maybe move into sending a basic "Hello World" to the printer followed by an autocut?

This is hard since it is not easy to find good articles. If you look for information you will notice how epson is not really happy sharing their knowleage. bot here are some articles that helped me with this:
this article is really good if you want to print images Images
This one is from epson Epson
** Update **
this is what makes the magic:
Public Class EscPOS
Private Shared PrintNam As String = "POS"
Public Shared Property PrinterName
Set(value)
PrintNam = value
End Set
Get
Return PrintNam
End Get
End Property
' Structure and API declarions:
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)> _
Structure DOCINFOW
<MarshalAs(UnmanagedType.LPWStr)> Public pDocName As String
<MarshalAs(UnmanagedType.LPWStr)> Public pOutputFile As String
<MarshalAs(UnmanagedType.LPWStr)> Public pDataType As String
End Structure
<DllImport("winspool.Drv", EntryPoint:="OpenPrinterW", _
SetLastError:=True, CharSet:=CharSet.Unicode, _
ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Shared Function OpenPrinter(ByVal src As String, ByRef hPrinter As IntPtr, ByVal pd As Long) As Boolean
End Function
<DllImport("winspool.Drv", EntryPoint:="ClosePrinter", _
SetLastError:=True, CharSet:=CharSet.Unicode, _
ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Shared Function ClosePrinter(ByVal hPrinter As IntPtr) As Boolean
End Function
<DllImport("winspool.Drv", EntryPoint:="StartDocPrinterW", _
SetLastError:=True, CharSet:=CharSet.Unicode, _
ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Shared Function StartDocPrinter(ByVal hPrinter As IntPtr, ByVal level As Int32, ByRef pDI As DOCINFOW) As Boolean
End Function
<DllImport("winspool.Drv", EntryPoint:="EndDocPrinter", _
SetLastError:=True, CharSet:=CharSet.Unicode, _
ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Shared Function EndDocPrinter(ByVal hPrinter As IntPtr) As Boolean
End Function
<DllImport("winspool.Drv", EntryPoint:="StartPagePrinter", _
SetLastError:=True, CharSet:=CharSet.Unicode, _
ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Shared Function StartPagePrinter(ByVal hPrinter As IntPtr) As Boolean
End Function
<DllImport("winspool.Drv", EntryPoint:="EndPagePrinter", _
SetLastError:=True, CharSet:=CharSet.Unicode, _
ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Shared Function EndPagePrinter(ByVal hPrinter As IntPtr) As Boolean
End Function
<DllImport("winspool.Drv", EntryPoint:="WritePrinter", _
SetLastError:=True, CharSet:=CharSet.Unicode, _
ExactSpelling:=True, CallingConvention:=CallingConvention.StdCall)> _
Public Shared Function WritePrinter(ByVal hPrinter As IntPtr, ByVal pBytes As IntPtr, ByVal dwCount As Int32, ByRef dwWritten As Int32) As Boolean
End Function
Public Shared Function PrintImage(BM As Bitmap) As Boolean
Dim b As Byte() = ConvertImagetoBytes(BM)
Dim bSuccess As Boolean
Dim pUnmanagedBytes As IntPtr
' Allocate some unmanaged memory for those bytes.
pUnmanagedBytes = Marshal.AllocCoTaskMem(b.Count)
' Copy the managed byte array into the unmanaged array.
Marshal.Copy(b, 0, pUnmanagedBytes, b.Count)
' Send the unmanaged bytes to the printer.
bSuccess = EscPOS.PrintBytes(b)
Return bSuccess
End Function
Public Shared Function PrintBytes(Document As Byte()) As Boolean
Dim hPrinter As IntPtr ' The printer handle.
Dim dwError As Int32 ' Last error - in case there was trouble.
Dim di As DOCINFOW ' Describes your document (name, port, data type).
Dim dwWritten As Int32 ' The number of bytes written by WritePrinter().
Dim bSuccess As Boolean ' Your success code.
' Set up the DOCINFO structure.
di = New DOCINFOW
di.pDocName = "RAW LOGO"
di.pDataType = "RAW"
hPrinter = New IntPtr(0)
bSuccess = False
If OpenPrinter(PrinterName.Normalize(), hPrinter, 0) Then
If StartDocPrinter(hPrinter, 1, di) Then
Dim managedData As Byte()
Dim unmanagedData As IntPtr
managedData = Document
unmanagedData = Marshal.AllocCoTaskMem(managedData.Length)
Marshal.Copy(managedData, 0, unmanagedData, managedData.Length)
If StartPagePrinter(hPrinter) Then
bSuccess = WritePrinter(hPrinter, unmanagedData, managedData.Length, dwWritten)
EndPagePrinter(hPrinter)
End If
Marshal.FreeCoTaskMem(unmanagedData)
EndDocPrinter(hPrinter)
End If
ClosePrinter(hPrinter)
End If
If bSuccess = False Then
dwError = Marshal.GetLastWin32Error()
End If
Return bSuccess
End Function
Public Shared Function ConvertImagetoBytes(BM As Bitmap) As Byte()
Dim Data As BitMapData = GetBitmapData(BM)
Dim Op As New MemoryStream
Dim bw As New BinaryWriter(Op)
bw.Write(Chr(Keys.Escape))
bw.Write("#"c)
' So we have our bitmap data sitting in a bit array called "dots."
' This is one long array of 1s (black) and 0s (white) pixels arranged
' as if we had scanned the bitmap from top to bottom, left to right.
' The printer wants to see these arranged in bytes stacked three high.
' So, essentially, we need to read 24 bits for x = 0, generate those
' bytes, and send them to the printer, then keep increasing x. If our
' image is more than 24 dots high, we have to send a second bit image
' command to draw the next slice of 24 dots in the image.
' Set the line spacing to 24 dots, the height of each "stripe" of the
' image that we're drawing. If we don't do this, and we need to
' draw the bitmap in multiple passes, then we'll end up with some
' whitespace between slices of the image since the default line
' height--how much the printer moves on a newline--is 30 dots.
bw.Write(Chr(Keys.Escape))
bw.Write("3"c)
' '3' just means 'change line height command'
bw.Write(CByte(24))
' OK. So, starting from x = 0, read 24 bits down and send that data
' to the printer. The offset variable keeps track of our global 'y'
' position in the image. For example, if we were drawing a bitmap
' that is 48 pixels high, then this while loop will execute twice,
' once for each pass of 24 dots. On the first pass, the offset is
' 0, and on the second pass, the offset is 24. We keep making
' these 24-dot stripes until we've run past the height of the
' bitmap.
Dim offset As Integer = 0
Dim width As Byte()
While offset < Data.Height
' The third and fourth parameters to the bit image command are
' 'nL' and 'nH'. The 'L' and the 'H' refer to 'low' and 'high', respectively.
' All 'n' really is is the width of the image that we're about to draw.
' Since the width can be greater than 255 dots, the parameter has to
' be split across two bytes, which is why the documentation says the
' width is 'nL' + ('nH' * 256).
bw.Write(Chr(Keys.Escape))
bw.Write("*"c)
' bit-image mode
bw.Write(CByte(33))
' 24-dot double-density
width = BitConverter.GetBytes(Data.Width)
bw.Write(width(0))
' width low byte
bw.Write(width(1))
' width high byte
For x As Integer = 0 To Data.Width - 1
' Remember, 24 dots = 24 bits = 3 bytes.
' The 'k' variable keeps track of which of those
' three bytes that we're currently scribbling into.
For k As Integer = 0 To 2
Dim slice As Byte = 0
' A byte is 8 bits. The 'b' variable keeps track
' of which bit in the byte we're recording.
For b As Integer = 0 To 7
' Calculate the y position that we're currently
' trying to draw. We take our offset, divide it
' by 8 so we're talking about the y offset in
' terms of bytes, add our current 'k' byte
' offset to that, multiple by 8 to get it in terms
' of bits again, and add our bit offset to it.
Dim y As Integer = (((offset \ 8) + k) * 8) + b
' Calculate the location of the pixel we want in the bit array.
' It'll be at (y * width) + x.
Dim i As Integer = (y * Data.Width) + x
' If the image (or this stripe of the image)
' is shorter than 24 dots, pad with zero.
Dim v As Boolean = False
If i < Data.Dots.Length Then
v = Data.Dots(i)
End If
' Finally, store our bit in the byte that we're currently
' scribbling to. Our current 'b' is actually the exact
' opposite of where we want it to be in the byte, so
' subtract it from 7, shift our bit into place in a temp
' byte, and OR it with the target byte to get it into there.
slice = slice Or CByte((If(v, 1, 0)) << (7 - b))
Next
' Phew! Write the damn byte to the buffer
bw.Write(slice)
Next
Next
' We're done with this 24-dot high pass. Render a newline
' to bump the print head down to the next line
' and keep on trucking.
offset = offset + 24
bw.Write(vbCrLf.ToCharArray)
End While
' Restore the line spacing to the default of 30 dots.
bw.Write(Chr(Keys.Escape))
bw.Write("3"c)
bw.Write(CByte(30))
bw.Flush()
Return Op.ToArray
End Function
Private Shared Function GetBitmapData(BM As Bitmap) As BitMapData
Dim threshold = 127
Dim index As Integer = 0
Dim dimensions As Integer = BM.Width * BM.Height
Dim dots As BitArray = New BitArray(dimensions)
Dim res As New BitMapData
Dim a As Integer
For y = 0 To BM.Height - 1
For x = 0 To BM.Width - 1
Dim col As Color = BM.GetPixel(x, y)
Dim luminance = CInt(col.R * 0.3 + col.G * 0.59 + col.B * 0.11)
If (luminance < threshold) = True Then
a = 1
End If
dots(index) = (luminance < threshold)
index = index + 1
Next
Next
res.Dots = dots : res.Height = BM.Height : res.Width = BM.Width
Return res
End Function
Private Class BitMapData
Public Dots As BitArray
Public Height As Int16
Public Width As Int16
End Class
' When the function is given a printer name and an unmanaged array of
' bytes, the function sends those bytes to the print queue.
' Returns True on success or False on failure.
Private Shared Function PrintEsto(ByVal pBytes As IntPtr, ByVal dwCount As Int32) As Boolean
Dim hPrinter As IntPtr ' The printer handle.
Dim dwError As Int32 ' Last error - in case there was trouble.
Dim di As DOCINFOW = Nothing ' Describes your document (name, port, data type).
Dim dwWritten As Int32 ' The number of bytes written by WritePrinter().
Dim bSuccess As Boolean ' Your success code.
' Set up the DOCINFO structure.
With di
.pDocName = "RAW Document"
.pDataType = "RAW"
End With
' Assume failure unless you specifically succeed.
bSuccess = False
If OpenPrinter(PrinterName, hPrinter, 0) Then
If StartDocPrinter(hPrinter, 1, di) Then
If StartPagePrinter(hPrinter) Then
' Write your printer-specific bytes to the printer.
bSuccess = WritePrinter(hPrinter, pBytes, dwCount, dwWritten)
EndPagePrinter(hPrinter)
End If
EndDocPrinter(hPrinter)
End If
ClosePrinter(hPrinter)
End If
' If you did not succeed, GetLastError may give more information
' about why not.
If bSuccess = False Then
dwError = Marshal.GetLastWin32Error()
End If
Return bSuccess
End Function
' SendFileToPrinter()
' When the function is given a file name and a printer name,
' the function reads the contents of the file and sends the
' contents to the printer.
' Presumes that the file contains printer-ready data.
' Shows how to use the SendBytesToPrinter function.
' Returns True on success or False on failure.
Public Shared Function PrintFile(ByVal szFileName As String) As Boolean
' Open the file.
Try
Dim fs As New FileStream(szFileName, FileMode.Open)
' Create a BinaryReader on the file.
Dim br As New BinaryReader(fs)
' Dim an array of bytes large enough to hold the file's contents.
Dim bytes(fs.Length) As Byte
Dim bSuccess As Boolean
' Your unmanaged pointer.
Dim pUnmanagedBytes As IntPtr
' Read the contents of the file into the array.
bytes = br.ReadBytes(fs.Length)
' Allocate some unmanaged memory for those bytes.
pUnmanagedBytes = Marshal.AllocCoTaskMem(fs.Length)
' Copy the managed byte array into the unmanaged array.
Marshal.Copy(bytes, 0, pUnmanagedBytes, fs.Length)
' Send the unmanaged bytes to the printer.
bSuccess = PrintEsto(pUnmanagedBytes, fs.Length)
' Free the unmanaged memory that you allocated earlier.
Marshal.FreeCoTaskMem(pUnmanagedBytes)
fs.Close()
Return bSuccess
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
' When the function is given a string and a printer name,
' the function sends the string to the printer as raw bytes.
Public Shared Function PrintString(ByVal szString As String)
Dim pBytes As IntPtr
Dim dwCount As Int32
Dim Res As Boolean
' How many characters are in the string?
dwCount = szString.Length()
' Assume that the printer is expecting ANSI text, and then convert
' the string to ANSI text.
pBytes = Marshal.StringToCoTaskMemAnsi(szString)
' Send the converted ANSI string to the printer.
Res = PrintEsto(pBytes, dwCount)
Marshal.FreeCoTaskMem(pBytes)
Return Res
End Function
End Class
And this is how I call whit class:
If EsImpresionTermica Then
If File.Exists(My.Application.Info.DirectoryPath & "\Settings.{2559a1f2-21d7-11d4-bdaf-00c04f60b9f0}\Logo.conf") Then _
RawPrinting.EscPOS.PrintBytes(File.ReadAllBytes(My.Application.Info.DirectoryPath & "\Settings.{2559a1f2-21d7-11d4-bdaf-00c04f60b9f0}\Logo.conf"))
Else
Dim MSe As New MemoryStream
Dim BWe As New BinaryWriter(MSe)
BWe.Write(Chr(&H1B))
BWe.Write("#"c) 'Inicia Imresora
BWe.Write(Chr(&H1B))
BWe.Write(CByte(3))
BWe.Write(Chr(18)) 'Establece interlineado
BWe.Write(Chr(&H1B))
BWe.Write("U"c)
BWe.Write(Chr(1)) 'ImpresiĆ³n unidireccional
BWe.Write(Chr(&H1B))
BWe.Write("a"c)
BWe.Write(Chr(1)) 'Centra ImpresiĆ³n
BWe.Write(Chr(&H1B))
BWe.Write(vbCrLf.ToCharArray)
BWe.Write(Encoding.ASCII.GetBytes(Encabezado))
BWe.Write(Chr(10))
BWe.Write(Chr(10))
BWe.Flush()
BWe.Close()
RawPrinting.EscPOS.PrintBytes(MSe.ToArray)
End If
End Sub

Related

How do I perform unicode normalization for password storage in VBA?

I want to store and compare hashed passwords in VBA.
I've read How do I properly implement Unicode passwords?, but I have no clue about where to start.
How do I normalize a unicode string in VBA?
Preferably, I'd do this without downloading the ICU the linked post refers to, because I'd like my project not to be dependent on external code.
Windows provides a built-in for normalizing strings, the NormalizeString function. However, it can be a bit tricky to use.
Here is an implementation, based on the C example in the docs provided above:
'Declare the function
Public Declare PtrSafe Function NormalizeString Lib "Normaliz.dll" (ByVal NormForm As Byte, ByVal lpSrcString As LongPtr, ByVal cwSrcLength As Long, ByVal lpDstString As LongPtr, ByVal cwDstLength As Long) As Long
'And a relevant error code
Const ERROR_INSUFFICIENT_BUFFER = 122
'And a helper enum
Public Enum NORM_FORM
NormalizationC = &H1
NormalizationD = &H2
NormalizationKC = &H5
NormalizationKD = &H6
End Enum
'Available normalization forms can be found under https://learn.microsoft.com/en-us/windows/win32/api/winnls/ne-winnls-norm_form
'KD normalization is preferred(https://stackoverflow.com/a/16173329/7296893) when hashing characters
'If you already have hashes stored, C normalization is least likely to break them
Public Function UnicodeNormalizeString(str As String, Optional norm_form As Byte = NormalizationKD) As String
If Len(str) = 0 Then 'Zero-length strings can't be normalized
UnicodeNormalizeString = str
Exit Function
End If
Dim outlenestimate As Long
'Get an initial length estimate for the string
outlenestimate = NormalizeString(norm_form, StrPtr(str), Len(str), 0, 0)
Dim i As Long
'Try 10 times
For i = 1 To 10
'Initialize buffer
UnicodeNormalizeString = String(outlenestimate, vbNullChar)
'Get either the normalized string, or a new length estimate
outlenestimate = NormalizeString(norm_form, StrPtr(str), Len(str), StrPtr(UnicodeNormalizeString), outlenestimate)
If outlenestimate > 0 Then 'We got the normalized string
'Truncate off the unused characters
UnicodeNormalizeString = Left(UnicodeNormalizeString, outlenestimate)
Exit Function
Else
If Err.LastDllError <> ERROR_INSUFFICIENT_BUFFER Then
Exit For 'An unexpected error occurred
End If
outlenestimate = outlenestimate * -1 'Use the new length estimate, try again
End If
Next
Err.Raise 5000, Description:="Failure to normalize unicode string"
End Function
Once you have declared the normalization function, always run your password through it before hashing:
If SomeHashFun(UnicodeNormalizeString(MyPassword)) = SomeHashedPassword Then
'We are in!
End If

How to perform face recognition using Dahua NVR from VB.NET

Has anyone used VB.NET to get face recognition data from a Dahua NVR using VB.NET?
I am facing two problems that I just can't figure out.
I can connect to the NVR and set up a callback for video using
bDeviceInitialized = CLIENT_Init(AddressOf DeviceDisconnected, 0)
Dim lSDKVersion As Long
lSDKVersion = CLIENT_GetSDKVersion()
console.writeline( "SDK: " + lSDKVersion.ToString.Substring(0, 1) + "." + lSDKVersion.ToString.Substring(1, 2) + " " + lSDKVersion.ToString.Substring(3) )
fAnalyzer = AddressOf AnalyzerDataCallBack
'Set reconnect callback
CLIENT_SetAutoReconnect(AddressOf DeviceReconnected, 0)
' Set device connection timeout And trial times.
' Optional operation
Dim nWaitTime As Integer = 5000 ' Timeout Is 5 seconds.
Dim nTryTimes As Integer = 3 ' If timeout, it will try to log in three times.
CLIENT_SetConnectTime(nWaitTime, nTryTimes)
'A wait is required
System.Threading.Thread.Sleep(1000)
netInLoginWithHighLevelSecurity.dwSize = Marshal.SizeOf(netInLoginWithHighLevelSecurity)
Array.Copy(System.Text.Encoding.Default.GetBytes(My.Settings.DeviceIP), netInLoginWithHighLevelSecurity.szIP, My.Settings.DeviceIP.Length)
netInLoginWithHighLevelSecurity.nPort = CInt(My.Settings.DevicePort)
Array.Copy(System.Text.Encoding.Default.GetBytes(My.Settings.DeviceUserId), netInLoginWithHighLevelSecurity.szUserName, My.Settings.DeviceUserId.Length)
Array.Copy(System.Text.Encoding.Default.GetBytes(My.Settings.DevicePassword), netInLoginWithHighLevelSecurity.szPassword, My.Settings.DevicePassword.Length)
netInLoginWithHighLevelSecurity.emSpecCap = EM_LOGIN_SPAC_CAP_TYPE.EM_LOGIN_SPEC_CAP_TCP
netOutLoginWithHighLevelSecurity.stuDeviceInfo = devInfo
netOutLoginWithHighLevelSecurity.dwSize = Marshal.SizeOf(netOutLoginWithHighLevelSecurity)
'Create a pointer for the structure
'pNetOutLoginWithHighLevelSecurity = Marshal.AllocHGlobal(Marshal.SizeOf(netOutLoginWithHighLevelSecurity))
hLoginId = CLIENT_LoginWithHighLevelSecurity(netInLoginWithHighLevelSecurity, netOutLoginWithHighLevelSecurity)
' Get the serial number of the NVR
Dim i As Integer = 0
Dim strSerial As String = ""
While i < 64 And netOutLoginWithHighLevelSecurity.stuDeviceInfo.sSerialNumber(i) <> 0
strSerial &= Chr(netOutLoginWithHighLevelSecurity.stuDeviceInfo.sSerialNumber(i))
i += 1
End While
' Enable cameras
Dim dwUser As Int64 = 0
Dim oReserved As IntPtr = 0
Dim nChannel As Int16 =0
Dim iNeedPicture As Int32 = 1
' pbChannel1 is a PictureBox
lMonitorChannel(nChannel) = CLIENT_RealPlayEx(hLoginId, nChannel, pbChannel1.Handle, EM_REAL_PLAY_TYPE.EM_REAL_PLAY_REALPLAY)
lAlarmFaceDetection(nChannel) = CLIENT_RealLoadPictureEx(hLoginId, nChannel, EVENT_IVS_ALL, iNeedPicture, fAnalyzer, Nothing, Nothing)
This works fine and I can see the video from channel 1.
The problems are in the analyzer callback which is defined as
Public Delegate Sub AnalyzerDataCallBackDelegate(lAnalyzerHandle As Int64, dwAlarmType As UInt32, AlarmInfo As IntPtr, pBuffer As IntPtr, dwBufferSize As UInt32, dwUser As Int64, nSequence As Int16, Reserved As IntPtr)
Public Shared Sub AnalyzerDataCallBack(ByVal lAnalyzerHandle As Int64, ByVal dwAlarmType As Int32, ByVal AlarmInfo As IntPtr,
ByVal pBuffer As IntPtr, ByVal dwBufferSize As Int32, ByVal dwUser As Int64, ByVal nSequence As Int16,
ByVal Reserved As IntPtr)
Firstly, I am not getting any event other than motion detect and face recognition, even though I subscribed to EVENT_IVS_ALL.
Secondly, I am not getting complete face recognition information.
I copied from the unmanaged buffer into a (complex) structure.
structFaceRecognitionInfo = CType(Marshal.PtrToStructure(AlarmInfo, GetType(DEV_EVENT_FACERECOGNITION_INFO)), DEV_EVENT_FACERECOGNITION_INFO)
But I don't get complete information. Only the first few elements are filled with the rest have garbage or zeros.
I tried copying the buffer into a byte array to inspect the data during debug and see that it is indeed filled with zeros.
Dim lenBuffer As Int32 = Marshal.SizeOf(Of DEV_EVENT_FACERECOGNITION_INFO)
ReDim bData(lenBuffer)
Dim gchBuffer As GCHandle = GCHandle.Alloc(bData, GCHandleType.Pinned)
Marshal.Copy(AlarmInfo, bData, 0, lenBuffer)
gchBuffer.Free()
I've been stuck at this point for a week.

Access vba function called from Excel results in different value returned

My ultimate goal is to generate a tool to predict the width of a string, so that I can avoid text overflow when printing reports in MS Access 2010. Options like CanGrow are not useful, because my reports cannot have unpredicted page breaks. I cannot cut off text.
To this end I discovered the undocumented WizHook.TwipsFromFont function in Access. It returns the width in twips of a string given font and other characteristics. It has proven quite useful as a starting point. Based on various user generated guides, I developed the following in Access:
Public Function TwipsFromFont(ByVal sCaption As String, ByVal sFontName As String, _
ByVal lSize As Long, Optional ByVal lWeight As Long = 400, _
Optional bItalic As Boolean = False, _
Optional bUnderline As Boolean = False, _
Optional lCch As Long = 0, _
Optional lMaxWidthCch As Long = 0) As Double
'inspired by http://www.team-moeller.de/?Tipps_und_Tricks:Wizhook-Objekt:TwipsFromFont
WizHook.Key = 51488399
Dim ldx As Long
Dim ldy As Long
Call WizHook.TwipsFromFont(sFontName, lSize, lWeight, bItalic, bUnderline, lCch, _
sCaption, lMaxWidthCch, ldx, ldy)
'Debug.Print CDbl(ldx)
TwipsFromFont = CDbl(ldx)
'TwipsFromFont = 99999
End Function
However, the data that will end up in Access is initially going to be generated in Excel 2010. Therefore, I would like to call this function in Excel, so I can check strings as they are created. To this end, I developed the following in Excel:
Public Function TwipsFromFontXLS() As Double
Dim obj As Object
Set obj = CreateObject("Access.Application")
With obj
.OpenCurrentDatabase "C:\MyPath\Jeremy.accdb"
TwipsFromFontXLS = .Run("TwipsFromFont", sCaption = "Hello World!", _
sFontName = "Arial Black", lSize = 20)
.Quit
End With
Set obj = Nothing
End Function
When I run debug.Print TwipsFromFont("Hello World!","Arial Black",20) in Access I get back 2670. When I run debug.Print TwipsFromFontXLS() in Excel I get back 585.
In Access, if I set TwipsFomFont = 9999, then debug.Print TwipsFromFontXLS() will return 9999.
Any thoughts on where my disconnect is?
For those that are interested, the issue turned out to be how Application.Run passed arguments. I was explicitly identifying my arguments, and this apparently created an issue. Below is code that appears to work when I call it in Excel. It isn't particularly fast, but at this point it works.
In Access:
Public Function TwipsFromFont(ByVal sCaption As String, ByVal sFontName As String, ByVal lSize As Long, Optional ByVal lWeight As Long = 400, Optional bItalic As Boolean = False, Optional bUnderline As Boolean = False, Optional lCch As Long = 0, Optional lMaxWidthCch As Long = 0) As Double
'inspired by http://www.team-moeller.de/?Tipps_und_Tricks:Wizhook-Objekt:TwipsFromFont
'required to call WizHook functions
WizHook.Key = 51488399
'width (ldx) and height (ldy) variables will be changed ByRef in the TwipsFromFont function
Dim ldx As Long
Dim ldy As Long
'call undocumented function
Call WizHook.TwipsFromFont(sFontName, lSize, lWeight, bItalic, bUnderline, lCch, sCaption, lMaxWidthCch, ldx, ldy)
'return printed text width in twips (1440 twips = 1 inch, 72 twips = 1 point, 20 points = 1 inch)
TwipsFromFont = CDbl(ldx)
End Function
In Excel:
Public Function TwipsFromFontXLS(ByVal sCaption As String, ByVal sFontName As String, ByVal lSize As Long, Optional ByVal lWeight As Long = 400, Optional bItalic As Boolean = False, Optional bUnderline As Boolean = False, Optional lCch As Long = 0, Optional lMaxWidthCch As Long = 0) As Double
'calls the WizHook.TwipsFromFont function from MS Access to calculate text width in twips
'create the application object
Dim obj As Object
Set obj = CreateObject("Access.Application")
With obj
'call the appropriate Access database
.OpenCurrentDatabase "C:\MyPath\Jeremy.accdb"
'pass the arguments to the Access function
'sCaption = the string to measure; sFontName = the Font; lSize = text size in points; lWeight = boldness, 400 is regular, 700 is bold, bItalic = italic style, bUnderline = underline style, lCch = number of characters with average width, lMaxwidth = number of characters with maximum width
TwipsFromFontXLS = .Run("TwipsFromFont", sCaption, sFontName, lSize, lWeight, bItalic, bUnderline, lCch, lMaxwidth)
'close the connection to the Access database
.Quit
End With
End Function
As remarked in Application.Run method:
You cannot use named arguments with this method. Arguments must be
passed by position.
So simply remove sCaption, sFontName, and lSize and Excel call should return exact same as Access call, namely 2670. Explicitly defining all non-optional arguments is not needed.
Public Function TwipsFromFontXLS() As Double
Dim obj As Object
Set obj = CreateObject("Access.Application")
With obj
.OpenCurrentDatabase "C:\MyPath\Jeremy.accdb"
TwipsFromFontXLS = .Run("TwipsFromFont", "Hello World!", "Arial Black", 20)
.Quit
End With
Set obj = Nothing
End Function
In fact, had OP including Option Explicit at top of module, these named arguments should have raised a runtime even compiled error as being undefined!

GdipSaveImageToFile(), pointer to a Structure/Class in VB.net

I am using GdipSaveImageToFile() from GDI+ dll. It works all right if I send a null pointer in the last parameter (EncoderParameters)
<System.Runtime.InteropServices.DllImport("gdiplus.dll", ExactSpelling:=True, CharSet:=System.Runtime.InteropServices.CharSet.Unicode)>
Friend Shared Function GdipSaveImageToFile(image As IntPtr, filename As String, <System.Runtime.InteropServices.[In]> ByRef clsid As Guid, encparams As IntPtr) As Integer
End Function
Sub test(hbmp as IntPtr, filename as String, clsid as Guid)
Dim status as Integer = GdipSaveImageToFile(hbmp, filename, clsid, IntPtr.Zero)
If status <> 0 Then
MessageBox.Show("Error status = " & status)
End If
End Sub
The code saves the image to a file using the standard settings.
Now, I have been strugling sending a real pointer in the last parameter (EncoderParameters) in vb.net.
Here is my attempt:
<System.Runtime.InteropServices.DllImport("gdiplus.dll", ExactSpelling:=True, CharSet:=System.Runtime.InteropServices.CharSet.Unicode)>
Friend Shared Function GdipSaveImageToFile(image As IntPtr, filename As String, <System.Runtime.InteropServices.[In]> ByRef clsid As Guid, ByRef encparams As cEncoderParameters) As Integer
End Function
<StructLayout(LayoutKind.Sequential, Pack:=2, CharSet:=CharSet.Ansi)>
Friend Structure cEncoderParameter
Public GUID As Guid
Public NumberOfValues As UInt32
Public type As UInt32
Public Value As IntPtr
End Structure
<StructLayout(LayoutKind.Sequential, Pack:=2)>
Friend Class cEncoderParameters
Public Count As UInt32
Public Parameter As cEncoderParameter
End Class
Friend Enum cEncoderParameterType As UInt32
EncoderParameterValueTypeByte = 1 ' 8-bit unsigned int
EncoderParameterValueTypeASCII = 2 ' 8-bit byte containing one 7-bit ASCII code. NULL terminated.
EncoderParameterValueTypeShort = 3 ' 16-bit unsigned int
EncoderParameterValueTypeLong = 4 ' 32-bit unsigned int
EncoderParameterValueTypeRational = 5 ' Two Longs. The first Long Is the numerator, the second Long expresses the denomintor.
EncoderParameterValueTypeLongRange = 6 ' Two longs which specify a range of integer values. The first Long specifies the
' lower end And the second one specifies the higher end. All values are inclusive at both ends
EncoderParameterValueTypeUndefined = 7 ' 8-bit byte that can take any value depending on field definition
EncoderParameterValueTypeRationalRange = 8 ' Two Rationals. The first Rational specifies the lower end And the second specifies
' the higher end. All values are inclusive at both ends
EncoderParameterValueTypePointer = 9 ' A pointer to a parameter defined data.
End Enum
Sub b(hbmp As IntPtr, filename As String, clsid As Guid)
Dim eps As New cEncoderParameters
eps.Count = 1
eps.Parameter.GUID = Encoder.Quality.Guid
eps.Parameter.NumberOfValues = 1
eps.Parameter.type = cEncoderParameterType.EncoderParameterValueTypeLong
eps.Parameter.Value = New IntPtr(10)
If GdipSaveImageToFile(hbmp, filename, clsid, eps) <> 0 Then
MessageBox.Show("Error")
End If
End Sub
But the code breaks at the GdipSaveImageToFile(), with the following message
An unhandled exception of type 'System.AccessViolationException'
occurred in TWAIN.exe
Additional information: Attempted to read or write protected memory.
This is often an indication that other memory is corrupt.
I also tried to change EncoderParameter definition from Class to Structure, and the following code
Dim pEnc As IntPtr = Marshal.AllocHGlobal(Marshal.SizeOf(eps))
Marshal.StructureToPtr(eps, pEnc, False)
status = GdipSaveImageToFile(hbmp, filename, clsid, pEnc)
Marshal.FreeHGlobal(pEnc)
But I get a similar error message
Any ideas? I am burn out :)
Additional information: Definitions from gdiplusimaging.h, gdiplusflat.h
class EncoderParameter
{
public:
GUID Guid; // GUID of the parameter
ULONG NumberOfValues; // Number of the parameter values
ULONG Type; // Value type, like ValueTypeLONG etc.
VOID* Value; // A pointer to the parameter values
};
class EncoderParameters
{
public:
UINT Count; // Number of parameters in this structure
EncoderParameter Parameter[1]; // Parameter values
};
GpStatus WINGDIPAPI
GdipSaveImageToFile(GpImage *image, GDIPCONST WCHAR* filename,
GDIPCONST CLSID* clsidEncoder,
GDIPCONST EncoderParameters* encoderParams);

VB NET - ZLIB - Uncompress a stream

I have a little class that can uncompress a byte array with zlib. Here it is :
<Runtime.InteropServices.DllImport("zlib1.DLL", CallingConvention:=Runtime.InteropServices.CallingConvention.Cdecl, EntryPoint:="compress2", charset:=Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function CompressByteArray2(ByVal dest As Byte(), ByRef destLen As Integer, ByVal src As Byte(), ByVal srcLen As Integer, ByVal level As Integer) As Integer
End Function
Public Shared Function DeCompressBytes(ByVal Bytes() As Byte) As Byte()
Dim OrigSize As Integer = BitConverter.ToUInt32(Bytes, 0)
Dim Data(Bytes.Length - 5) As Byte
Array.Copy(Bytes, 4, Data, 0, Bytes.Length - 4)
Dim DLLfunctionResult As Integer
Dim bResult(CInt(OrigSize + (OrigSize * 0.01) + 12)) As Byte
DLLfunctionResult = UncompressByteArray(bResult, OrigSize, Data, Data.Length)
If DLLfunctionResult = 0 Then
ReDim Preserve bResult(OrigSize - 1)
Return bResult
Else
Return Bytes
End If
End Function
It Works, no problem.
I would like to know if it's possible to uncompress from a stream instead of a byte array. Because right now, I have to read the stream and put it in a variable, then uncompress it and put the new result in a variable. The purpose is to accelerate the process. Maybe it will not do that, but I would still like to know about
(French here, sorry for my english)