Sven Schubert
asked on
Need Help to convert code from VB.Net --> VBA !!!
Can anybody help me to convert this code from VB.NET to VBA. It should afterwards be running on a system with: Win10, Excel 2013, VBA
Here is the original Code in VB.NET including the improvment further down in the thread:
Source: https://stackoverflow.com/questions/103725/is-there-a-way-to-programmatically-determine-if-a-font-file-has-a-specific-unico
I would be very happy to get this translated. Any help very welcome.
Many thanks.
Here is the original Code in VB.NET including the improvment further down in the thread:
Source: https://stackoverflow.com/questions/103725/is-there-a-way-to-programmatically-determine-if-a-font-file-has-a-specific-unico
<DllImport("gdi32.dll")> _
Public Shared Function GetFontUnicodeRanges(ByVal hds As IntPtr, ByVal lpgs As IntPtr) As UInteger
End Function
<DllImport("gdi32.dll")> _
Public Shared Function SelectObject(ByVal hDc As IntPtr, ByVal hObject As IntPtr) As IntPtr
End Function
Public Structure FontRange
Public Low As UInt16
Public High As UInt16
End Structure
Public Function GetUnicodeRangesForFont(ByVal font As Font) As List(Of FontRange)
Dim g As Graphics
Dim hdc, hFont, old, glyphSet As IntPtr
Dim size As UInteger
Dim fontRanges As List(Of FontRange)
Dim count As Integer
g = Graphics.FromHwnd(IntPtr.Zero)
hdc = g.GetHdc()
hFont = font.ToHfont()
old = SelectObject(hdc, hFont)
size = GetFontUnicodeRanges(hdc, IntPtr.Zero)
glyphSet = Marshal.AllocHGlobal(CInt(size))
GetFontUnicodeRanges(hdc, glyphSet)
fontRanges = New List(Of FontRange)
count = Marshal.ReadInt32(glyphSet, 12)
For i As Integer = 0 To count - 1
Dim range As FontRange = New FontRange
range.Low = Unsign(Marshal.ReadInt16(glyphSet, 16 + (i * 4)))
range.High = range.Low + Unsign(Marshal.ReadInt16(glyphSet, 18 + (i * 4)) - 1)
fontRanges.Add(range)
Next
SelectObject(hdc, old)
Marshal.FreeHGlobal(glyphSet)
g.ReleaseHdc(hdc)
g.Dispose()
Return fontRanges
End Function
Public Function CheckIfCharInFont(ByVal character As Char, ByVal font As Font) As Boolean
Dim intval As UInt16 = Convert.ToUInt16(character)
Dim ranges As List(Of FontRange) = GetUnicodeRangesForFont(font)
Dim isCharacterPresent As Boolean = False
For Each range In ranges
If intval >= range.Low And intval <= range.High Then
isCharacterPresent = True
Exit For
End If
Next range
Return isCharacterPresent
End Function
Protected Function Unsign(ByVal Input As Int16) As UInt16
If Input > -1 Then
Return CType(Input, UInt16)
Else
Return UInt16.MaxValue - (Not Input)
End If
End Function
I would be very happy to get this translated. Any help very welcome.
Many thanks.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Do you know how to program in the VBA environment?
ASKER
Only a little bit. For this - with external APIs/dlls - my knowledge is not good enough.
And I would not be able to figure out why the current code doesn't work properly for my purpose.
That's why I still need help. Many thanks if you can help me.
And I would not be able to figure out why the current code doesn't work properly for my purpose.
That's why I still need help. Many thanks if you can help me.
I think that level of hand-holding would be a good case for Live or Gigs
ASKER
I will have to read what that means. I am not fammiliar with those terms yet.
ASKER
Thanks for the answer. I will somehow manage to get my results.
ASKER
I had a look at the code. Unfortunately, on my system the results are not correct OR it has been written with a different goal in mind. The issue is, even though many characters get displayed correctly after running the code, the evaluation column doesn't show that this character is part of the font.
Besides that, I'm not able to transform this code into a function like this one: Function IsCharacterPartOfFont (Character as String, Font as ??) as boolean
Would you or anybody else be able to:
Many thanks for your help.