VBA Makro für 32bit und 64bit VBA7
28.05.2021 15:28:45
GuideThomas
Ich bin mit Excel von der 32bit Version auf die 64bit Version umgestiegen. Jetzt läuft ein für mich wichtiges Makro leider nicht mehr, welches nun bei mir auf der 64bit Version als auch weiterhin auf einem Rechner mit Excel 32bit laufen sollte.
Es geht in diesem Makro darum Unicode bzw. UTF8 Sonderzeichen in einen sauberen String umzuwandeln.
Ich bin mit der Ergänzung von PtrSafe und dem Definieren von LongPtr anstelle von Long im VBA7 Code schon ein Stück weit gekommen ... dennoch steht der Ablauf (u.a. bei 1NC = 1Bytes) immer wieder aufgrund unverträglicher Typen im Block für VBA7.
Findet zufällig jemand auf den ersten Blick den Fehler?
Option Explicit
Private Const CP_UTF8 = 65001
#If VBA7 Then
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
ByVal CodePage As Long, ByVal dwFlags As Long, _
ByVal lpMultiByteStr As LongPtr, ByVal cchMultiByte As LongPtr, _
ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr) As LongPtr
Public Function getTranslation(ByVal url As String) As String
Dim sResponse As String
With CreateObject("MSXML2.ServerXMLHTTP.6.0")
.Open "GET", url, False: .Send
sResponse = StrConv(.responseBody, vbUnicode)
getTranslation = sUTF8ToUni(StrConv(sResponse, vbFromUnicode))
End With
End Function
Public Function sUTF8ToUni(bySrc() As Byte) As String
' Converts a UTF-8 byte array to a Unicode string
Dim lBytes As LongPtr, lNC As Long, lRet As LongPtr
lBytes = UBound(bySrc) - LBound(bySrc) + 1
lNC = lBytes
sUTF8ToUni = String$(lNC, Chr(0))
lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(bySrc(LBound(bySrc))), lBytes, StrPtr(sUTF8ToUni), lNC)
sUTF8ToUni = Left$(sUTF8ToUni, lRet)
End Function
#Else
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
ByVal CodePage As Long, ByVal dwFlags As Long, _
ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _
ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Public Function getTranslation(ByVal url As String) As String
Dim sResponse As String
With CreateObject("MSXML2.ServerXMLHTTP.6.0")
.Open "GET", url, False: .Send
sResponse = StrConv(.responseBody, vbUnicode)
getTranslation = sUTF8ToUni(StrConv(sResponse, vbFromUnicode))
End With
End Function
Public Function sUTF8ToUni(bySrc() As Byte) As String
' Converts a UTF-8 byte array to a Unicode string
Dim lBytes As Long, lNC As Long, lRet As Long
lBytes = UBound(bySrc) - LBound(bySrc) + 1
lNC = lBytes
sUTF8ToUni = String$(lNC, Chr(0))
lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(bySrc(LBound(bySrc))), lBytes, StrPtr(sUTF8ToUni), lNC)
sUTF8ToUni = Left$(sUTF8ToUni, lRet)
End Function
#End If