Regular
Beiträge: 66
Ort: Röthenbach a.d.Peg. | Hallo,
folgender Code in ein Standard Modul kopieren und anschließend die Funktion Translation aufrufen.
Gruß
Gunter
Option Compare Database
Option Explicit
'***App Window Constants***
Public Const WIN_NORMAL = 1 'Open Normal
Public Const WIN_MAX = 3 'Open Maximized
Public Const WIN_MIN = 2 'Open Minimized
'***Error Codes***
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Private Declare Function apiShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (dest As Any, source As Any, _
ByVal bytes As Long)
Public Function Translation()
Dim strString As String
Dim bolLanguageTranslation As Boolean
bolLanguageTranslation = True
strString = "Der Text der übersetzt werden soll"
If Len(Trim(Replace(strString, vbCrLf, " "))) > 0 Then
Dim strUTF8 As String
strUTF8 = GetEncodedUTF8String(strString)
Dim strTrans As String
If bolLanguageTranslation = False Then 'EN
strTrans = "https://translate.google.de/?hl&ie=UTF-8&sl=en&tl=de&text=" & strUTF8 & "&op=translate"
fHandleFile strTrans, WIN_NORMAL
Else 'DE
strTrans = "https://translate.google.de/?h=&ie=UTF-8&sl=de&tl=en&text=" & strUTF8 & "&op=translate"
fHandleFile strTrans, WIN_NORMAL
End If
End If
End Function
'***************Usage Examples***********************
'Open a folder: ?fHandleFile("C:\TEMP\",WIN_NORMAL)
'Call Email app: ?fHandleFile("mailto:dash10@hotmail.com",WIN_NORMAL)
'Open URL: ?fHandleFile("http://home.att.net/~dashish", WIN_NORMAL)
'Handle Unknown extensions (call Open With Dialog):
' ?fHandleFile("C:\TEMP\TestThis",Win_Normal)
'Start Access instance:
' ?fHandleFile("I:\mdbs\CodeNStuff.mdb", Win_NORMAL)
'****************************************************
Function fHandleFile(stFile As String, lShowHow As Long)
Dim lRet As Long, varTaskID As Variant
Dim stRet As String
'First try ShellExecute
lRet = apiShellExecute(hWndAccessApp, vbNullString, _
stFile, vbNullString, vbNullString, lShowHow)
If lRet > ERROR_SUCCESS Then
stRet = vbNullString
lRet = -1
Else
Select Case lRet
Case ERROR_NO_ASSOC:
'Try the OpenWith dialog
varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
& stFile, WIN_NORMAL)
lRet = (varTaskID <> 0)
Case ERROR_OUT_OF_MEM:
stRet = "Error: Out of Memory/Resources. Couldn't Execute!"
Case ERROR_FILE_NOT_FOUND:
stRet = "Error: File not found. Couldn't Execute!"
Case ERROR_PATH_NOT_FOUND:
stRet = "Error: Path not found. Couldn't Execute!"
Case ERROR_BAD_FORMAT:
stRet = "Error: Bad File Format. Couldn't Execute!"
Case Else:
End Select
End If
fHandleFile = lRet & _
IIf(stRet = "", vbNullString, ", " & stRet)
End Function
Public Function GetEncodedUTF8String( _
ByVal Text As String _
) As String
Dim Index1 As Long
Dim Index2 As Long
Dim Result As String
Dim Chars() As Byte
Dim Char As String
Dim Byte1 As Byte
Dim Byte2 As Byte
Dim UTF16 As Long
For Index1 = 1 To Len(Text)
CopyMemory Byte1, ByVal StrPtr(Text) + ((Index1 - 1) * 2), 1
CopyMemory Byte2, ByVal StrPtr(Text) + ((Index1 - 1) * 2) + 1, 1
UTF16 = Byte2
UTF16 = UTF16 * 256 + Byte1
Chars = GetUTF8FromUTF16(UTF16)
For Index2 = LBound(Chars) To UBound(Chars)
Char = Chr(Chars(Index2))
If Char Like "[0-9A-Za-z]" Then
Result = Result & Char
Else
Result = Result & "%" & Hex(Asc(Char))
End If
Next
Next
GetEncodedUTF8String = Result
End Function
Public Function GetUTF8FromUTF16( _
ByVal UTF16 As Long _
) As Byte()
Dim Result() As Byte
If UTF16 < &H80 Then
ReDim Result(0 To 0)
Result(0) = UTF16
ElseIf UTF16 < &H800 Then
ReDim Result(0 To 1)
Result(1) = &H80 + (UTF16 And &H3F)
UTF16 = UTF16 \ &H40
Result(0) = &HC0 + (UTF16 And &H1F)
Else
ReDim Result(0 To 2)
Result(2) = &H80 + (UTF16 And &H3F)
UTF16 = UTF16 \ &H40
Result(1) = &H80 + (UTF16 And &H3F)
UTF16 = UTF16 \ &H40
Result(0) = &HE0 + (UTF16 And &HF)
End If
GetUTF8FromUTF16 = Result
End Function
-----
Gruß
Gunter
--
Access FAQ: http://www.donkarl.com
http://www.avenius.de - http://www.AccessRibbon.de
http://www.ribboncreator.de - http://www.ribboncreator2010.de
http://www.ribboncreator2016.de - http://www.ribboncreator2019.de
|
