اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

قام بنشر

احبتي حتى لا أطيل في الشرح و  بدون مقدمات 

قصتي تتضح من عنواني و نبدء الآن ...

انشئ Module جديد و اضف الكود التالي

Option Explicit
Public Function Translate(strInput As String, strFromSourceLanguage As String, strToTargetLanguage As String) As String
Dim strURL As String
Dim objHTTP As Object
Dim objHTML As Object
Dim objDivs As Object, objDiv As Object
Dim strTranslated As String
strURL = "https://translate.google.com/m?hl=" & strFromSourceLanguage & _
    "&sl=" & strFromSourceLanguage & _
    "&tl=" & strToTargetLanguage & _
    "&ie=UTF-8&prev=_m&q=" & strInput
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP") 'late binding
objHTTP.Open "GET", strURL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ""
Set objHTML = CreateObject("htmlfile")
With objHTML
    .Open
    .Write objHTTP.responsetext
    .Close
End With
Set objDivs = objHTML.getElementsByTagName("div")
For Each objDiv In objDivs
    If objDiv.className = "t0" Then
        strTranslated = objDiv.innerText
        Translate = strTranslated
    End If
Next objDiv

Set objHTML = Nothing
Set objHTTP = Nothing
End Function

 

ثم يمكن تجربة هذه الشفرة الخاصة بتغيير لغة العرض بالطريقة التالية

MsgBox Translate("اهلا و سهلا", "ar", "en")

مرفق مثال تطبيقي على ما ورد اعلاه

و دمتم في رعاية الله و حفظه ... .

Data.mdbFetching info...

  • Like 6
  • Thanks 3
قام بنشر
  في 22‏/9‏/2020 at 07:27, ازهر عبد العزيز said:

ولا اروع

سؤال لو سمحت دكتور هل بالامكان اضافة لغات اضافية

 

بعد مراجعة الرابط الكود ياخذ الترجمة من google مباشرة شكرا دكتور 

 

Expand  

نعم تستطيع اضافة لغات اخرى فقط في اللغة المقابلة ضع رمز اللغة مثلا عربي ar انجلش en و هكذا .... ابحث عن رموز اللغات

 

  في 22‏/9‏/2020 at 07:36, محمد سلامة said:

جزاك الله خيراً د.كاف🌹

هل يتطلب وجود انترنت علي الجهاز؟

تحياتي

 

Expand  

نعم يتطلب وجود انترنت

  • Like 2
  • تمت الإجابة
قام بنشر

جزاك الله خيرا استاذنا الفاضل

  في 22‏/9‏/2020 at 13:02, ازهر عبد العزيز said:

دكتور لو سمحت هل بالامكان اضافة رسالة تحذيرة قي حال عدم توفر الانترنت الى الكود 

Expand  

من بعد اذن استاذي خسين

تفضل اخي الكريم

Option Compare Database
Option Explicit
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long

Private Sub أمر0_Click()

    If InternetGetConnectedState(0&, 0&) Then
        labal1.Caption = Translate(labal1.Caption, "ar", "en")
        labal2.Caption = Translate(labal2.Caption, "ar", "en")
        labal13.Caption = Translate(labal13.Caption, "ar", "en")
        Me.أمر19.Visible = True
    Else
        MsgBox "تأكد من اتصالك بالانترنت"
    End If

End Sub


Private Sub أمر19_Click()
    If InternetGetConnectedState(0&, 0&) Then
        labal1.Caption = Translate(labal1.Caption, "en", "ar")
        labal2.Caption = Translate(labal2.Caption, "en", "ar")
        labal13.Caption = Translate(labal13.Caption, "en", "ar")
    Else
        MsgBox "تأكد من اتصالك بالانترنت"
    End If
End Sub

تحياتي

  • Like 4
قام بنشر
  في 22‏/9‏/2020 at 23:49, محمد أبوعبدالله said:

جزاك الله خيرا استاذنا الفاضل

من بعد اذن استاذي خسين

تفضل اخي الكريم

Option Compare Database
Option Explicit
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long

Private Sub أمر0_Click()

    If InternetGetConnectedState(0&, 0&) Then
        labal1.Caption = Translate(labal1.Caption, "ar", "en")
        labal2.Caption = Translate(labal2.Caption, "ar", "en")
        labal13.Caption = Translate(labal13.Caption, "ar", "en")
        Me.أمر19.Visible = True
    Else
        MsgBox "تأكد من اتصالك بالانترنت"
    End If

End Sub


Private Sub أمر19_Click()
    If InternetGetConnectedState(0&, 0&) Then
        labal1.Caption = Translate(labal1.Caption, "en", "ar")
        labal2.Caption = Translate(labal2.Caption, "en", "ar")
        labal13.Caption = Translate(labal13.Caption, "en", "ar")
    Else
        MsgBox "تأكد من اتصالك بالانترنت"
    End If
End Sub

تحياتي

Expand  

ماشاء الله اضافة ممتازة و اشكرك على الرد 

قام بنشر

د.كاف يار

استاذنا الكريم بارك الله فيك على مجهودك الكريم

نعم تم تشغيل معي بدون غلطه 100%

ولكن في التقرير في حدث عن الفتح حاولت اخلي يترجم ما داخل النص ولكني عجزت

وستخدمت هذا الكود

Private Sub Report_Open(Cancel As Integer)
On Error Resume Next
Items_NameAdd_Exch.Text = Translate(Items_NameAdd_Exch.Text, "ar", "en")
End Sub

ولكنه تفشل معي هل الترجمه تنص فقط على الليبل فقط ولا تنطبق على ماهو داخل النص

شكرا لكم

قام بنشر
  في 23‏/9‏/2020 at 18:43, محمد حمزه said:

د.كاف يار

استاذنا الكريم بارك الله فيك على مجهودك الكريم

نعم تم تشغيل معي بدون غلطه 100%

ولكن في التقرير في حدث عن الفتح حاولت اخلي يترجم ما داخل النص ولكني عجزت

وستخدمت هذا الكود

Private Sub Report_Open(Cancel As Integer)
On Error Resume Next
Items_NameAdd_Exch.Text = Translate(Items_NameAdd_Exch.Text, "ar", "en")
End Sub

ولكنه تفشل معي هل الترجمه تنص فقط على الليبل فقط ولا تنطبق على ماهو داخل النص

شكرا لكم

Expand  

تفضل هذا التعديل اخي الكريم

Data.mdbFetching info...

  • Like 2
  • Thanks 1
قام بنشر (معدل)
  في 24‏/9‏/2020 at 09:34, Ali Mohamed Ali said:

أحسنت استاذ حسين عمل ممتاز بارك الله فيك وزادك الله من فضله

Expand  

العفو اخي الكريم الأجمل هو مرورك العطر و الجميل شكرا لك

=============================================

الاخوة الأعزاء تم اضافة اللغات المعتمدة في Google

تجدون النسخة المعدلة في المرفقات

translate_language.accdbFetching info...

تم تعديل بواسطه د.كاف يار
  • Thanks 2
قام بنشر
  في 24‏/9‏/2020 at 11:20, د.كاف يار said:

الاخوة الأعزاء تم اضافة اللغات المعتمدة في Google

تجدون النسخة المعدلة في المرفقات

Expand  

ابداع ليس له حدود 

هل بالامكان اضافة الرسالة التحذيرة بعدم وجود الانترنت للاستاذ محمد فلم استطع اضافتها واكم منا جزيل الشكر والعرفان 

قام بنشر
  في 24‏/9‏/2020 at 11:40, ازهر عبد العزيز said:

ابداع ليس له حدود 

هل بالامكان اضافة الرسالة التحذيرة بعدم وجود الانترنت للاستاذ محمد فلم استطع اضافتها واكم منا جزيل الشكر والعرفان 

Expand  

 

 

العفو اخي الكريم يشرفني مرورك و يشرفني أنه نال اعجابك

تفضل طلبك

translate_language.accdbFetching info...

  • Like 3
قام بنشر
  في 24‏/9‏/2020 at 12:49, د.كاف يار said:

العفو اخي الكريم يشرفني مرورك و يشرفني أنه نال اعجابك

تفضل طلبك

Expand  

جزاك الله عنا كل خير دكتور حفظكم الله ورعاكم والشكر موصول للاستاذ محمد ابو عبدالله 

قام بنشر

الموضوع فى قمة الروعة والابداع كل الشكر موصول لاستاذنا الرائع صاحب الموضوع

قام بنشر
  في 22‏/9‏/2020 at 06:43, د.كاف يار said:

احبتي حتى لا أطيل في الشرح و  بدون مقدمات 

قصتي تتضح من عنواني و نبدء الآن ...

انشئ Module جديد و اضف الكود التالي

Option Explicit
Public Function Translate(strInput As String, strFromSourceLanguage As String, strToTargetLanguage As String) As String
Dim strURL As String
Dim objHTTP As Object
Dim objHTML As Object
Dim objDivs As Object, objDiv As Object
Dim strTranslated As String
strURL = "https://translate.google.com/m?hl=" & strFromSourceLanguage & _
    "&sl=" & strFromSourceLanguage & _
    "&tl=" & strToTargetLanguage & _
    "&ie=UTF-8&prev=_m&q=" & strInput
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP") 'late binding
objHTTP.Open "GET", strURL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ""
Set objHTML = CreateObject("htmlfile")
With objHTML
    .Open
    .Write objHTTP.responsetext
    .Close
End With
Set objDivs = objHTML.getElementsByTagName("div")
For Each objDiv In objDivs
    If objDiv.className = "t0" Then
        strTranslated = objDiv.innerText
        Translate = strTranslated
    End If
Next objDiv

Set objHTML = Nothing
Set objHTTP = Nothing
End Function

بارك الله بك دكتور حسين التجربة كانت رائعة

 

Expand  

 

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information