• Vui lòng đọc nội qui diễn đàn để tránh bị xóa bài viết
  • Tìm kiếm trước khi đặt câu hỏi

Tạo một chương trình dịch văn bản tự động qua server Google

Các mẹo vặt linh tinh khác, không thuộc nhóm nào
dactung93
Thành viên tâm huyết
Thành viên tâm huyết
Posts: 496
Joined: Tue 04/11/2008 8:43 am
Has thanked: 6 times
Been thanked: 8 times

Tạo một chương trình dịch văn bản tự động qua server Google

Postby dactung93 » Sat 15/11/2008 6:51 pm

Thủ thuật: Tạo một chương trình dịch văn bản tự động qua server Google
Tác giả: Sưu tầm
Mô tả: Đây là cách kết nối với server Google để làm chương trình dịch
Nếu có gì thì chúng ta sẽ hợp làm. Đằng nào cũng vì cộng đồng mà.


Modules laytinve

Code: Select all

  1. Option Explicit
  2.  
  3. Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
  4. Private Const INTERNET_OPEN_TYPE_DIRECT = 1
  5. Private Const INTERNET_OPEN_TYPE_PROXY = 3
  6.  
  7. Private Const scUserAgent = "VBTagEdit"
  8. Private Const INTERNET_FLAG_RELOAD = &H80000000
  9.  
  10. Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
  11. (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
  12. ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
  13.  
  14. Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _
  15. (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, _
  16. ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
  17.  
  18. Private Declare Function InternetReadFile Lib "wininet.dll" _
  19. (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _
  20. lNumberOfBytesRead As Long) As Integer
  21.  
  22. Private Declare Function InternetCloseHandle Lib "wininet.dll" _
  23. (ByVal hInet As Long) As Integer
  24.  
  25. Private Declare Function URLDownloadToFile Lib "urlmon" _
  26.    Alias "URLDownloadToFileA" _
  27.   (ByVal pCaller As Long, _
  28.    ByVal szURL As String, _
  29.    ByVal szFileName As String, _
  30.    ByVal dwReserved As Long, _
  31.    ByVal lpfnCB As Long) As Long
  32.    
  33. Private Declare Function InternetGetConnectedState _
  34.               Lib "wininet.dll" (ByRef lpdwFlags As Long, _
  35.               ByVal dwReserved As Long) As Long
  36.    
  37. Private Const ERROR_SUCCESS As Long = 0
  38.  
  39. Public Function GetHTMLFromURL(sUrl As String) As String
  40. Dim S                  As String
  41. Dim hOpen              As Long
  42. Dim hOpenUrl           As Long
  43. Dim bDoLoop            As Boolean
  44. Dim bRet               As Boolean
  45. Dim sReadBuffer        As String * 2048
  46. Dim lNumberOfBytesRead As Long
  47.  
  48. hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
  49. hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
  50.  
  51. bDoLoop = True
  52.  
  53. While bDoLoop
  54.     sReadBuffer = vbNullString
  55.     bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
  56.     S = S & Left$(sReadBuffer, lNumberOfBytesRead)
  57.     If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
  58. Wend
  59.  
  60. If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
  61. If hOpen <> 0 Then InternetCloseHandle (hOpen)
  62.  
  63. GetHTMLFromURL = S
  64.  
  65. End Function
  66.  
  67. Public Function DownloadFile(ssourceUrl As String, _
  68.                              sLocalFile As String) As Boolean
  69.  
  70.    Dim lngRetVal As Long
  71.    
  72.   'nếu API trả về hàm ERROR_SUCCESS (0)
  73.   'trả về True từ hàm
  74.    DownloadFile = URLDownloadToFile(0&, _
  75.                                     ssourceUrl, _
  76.                                     sLocalFile, _
  77.                                     0&, _
  78.                                     0&) = ERROR_SUCCESS
  79.    
  80. End Function
  81.  
  82. Public Function IsConnected() As Boolean
  83.  
  84.     On Error GoTo err
  85.     IsConnected = InternetGetConnectedState(0&, 0&)
  86.  
  87. Exit Function
  88.  
  89. err:
  90.     IsConnected = True
  91.  
  92. End Function


Modules dich

Code: Select all

  1. Option Explicit
  2.  
  3. Global DefLang As String
  4.  
  5. 'url dich
  6. Const WebURL As String = "http://translate.google.com/translate_t"
  7.  
  8. 'Cái này chỉ cần trước khi dịch ( chuỗi cần dịch )
  9. Const SearchString As String = "result_box dir="  'Changer par Google le 2008-01-12
  10.  
  11. 'Trả về chuỗi sau khi đã dịch xong
  12. Const EndString As String = "</"
  13.  
  14. Public Function Traduction(InputText As String, LangueTrad As String) As String
  15. 'Nhưng        = Dịch một văn bản hay một ngôn ngữ khác
  16. '
  17. 'Text  = Nhấn text vô đây
  18. '
  19. 'Ngôn ngữ= Chọn
  20.  
  21. Dim TMPString  As String
  22. Dim StartPos   As Long
  23. Dim DebString  As String
  24. Dim InitString As String
  25.  
  26. If IsConnected = False Then
  27.    MsgBox "Ban chua ket noi Internet. Hay kiem tra va lam lai!", vbInformation, "Traduction"
  28.    Traduction = ""
  29.    Exit Function
  30. End If
  31.  
  32. 'Nhập text
  33. TMPString = GetHTMLFromURL(WebURL & "?langpair=" & LangueTrad & "&text=" & InputText)
  34.  
  35. InitString = SearchString & Chr(34) & "ltr" & Chr(34) & ">"
  36.  
  37. StartPos = InStr(1, TMPString, InitString, vbTextCompare)
  38. If StartPos = 0 Then
  39.    Traduction = ""
  40.    Exit Function
  41. End If
  42.  
  43. DebString = Right(TMPString, Len(TMPString) - (StartPos + Len(InitString) - 1))
  44.  
  45. StartPos = InStr(1, DebString, EndString, vbTextCompare)
  46.  
  47. Traduction = ReplaceHTMLString(Left(DebString, StartPos - 1))
  48.  
  49. End Function
  50.  
  51. Public Function ReplaceHTMLString(InputString) As String
  52. Dim retValue As String
  53.  
  54. retValue = Replace(InputString, "&#39;", "'", 1, -1, vbBinaryCompare)
  55.  
  56. ReplaceHTMLString = retValue
  57. End Function


Form

Code: Select all

  1. Option Explicit
  2. Dim TradLang As String
  3.  
  4. Private Sub cmdCopy_Click()
  5.   Clipboard.SetText Me.txtOutputText
  6. End Sub
  7.  
  8. Private Sub cmdTranslate_Click()
  9. Dim MyLang As Variant
  10.  
  11. '// Tiếng
  12. MyLang = Array("en|es", "en|fr", "en|it", _
  13.                "en|pt", "en|ja", "en|ko", _
  14.                "en|zh-CN", "de|en", "de|fr", _
  15.                "es|en", "fr|en", "fr|de", _
  16.                "it|en", "pt|en", "ja|en", "zh-CN|en")
  17.  
  18.  '// Chọn ngôn ngữ
  19.  TradLang = MyLang(Me.cboLang.ListIndex)
  20.  Me!txtOutputText = Traduction(Me.txtInputText, TradLang)
  21. End Sub
  22.  
  23. Private Sub Form_Load()
  24.  
  25. '// Fill combo
  26. With Me.cboLang
  27.  .AddItem "Ti?ng Anh sang Tây ban nha", 0
  28.  .AddItem "Ti?ng Anh sang Pháp", 1
  29.  .AddItem "Ti?ng Anh sang Italia", 2
  30.  .AddItem "Ti?ng Anh sang B? dào nha", 3
  31.  .AddItem "Ti?ng Anh sang Nh?t BETA", 4
  32.  .AddItem "Ti?ng Anh sang Hàn BETA", 5
  33.  .AddItem "Ð?c sang Ti?ng Anh", 6
  34.  .AddItem "Ð?c sang French", 7
  35.  .AddItem "Tây ban nha sang Ti?ng Anh", 8
  36.  .AddItem "Pháp sang Ti?ng Anh", 9
  37.  .AddItem "Pháp sang German", 10
  38.  .AddItem "Itali sang Ti?ng Anh", 11
  39.  .AddItem "B? sang Ti?ng Anh", 12
  40.  .AddItem "Nh?t sang Ti?ng Anh BETA", 13
  41.  .AddItem "Trung sang Ti?ng Anh BETA", 14
  42. '............................................................... Bạn tự cho vào (hơn mấy trăm cách cơ), Có cách hay hơn là bạn cho mỗi một ngôn ngữ 'một ký tự riêng. Chọn cái nào thì tự động nó lấy ký tự đó paste vô vào. Dùng cái array lâu hơn đấy :D
  43.  .ListIndex = 1
  44. End With
  45.  
  46. End Sub
Attachments
trans.rar
(3.56 KiB) Downloaded 739 times



luckyst
Thành viên chính thức
Thành viên chính thức
Posts: 21
Joined: Tue 29/07/2008 8:32 am
Location: Sóc Trăng
Has thanked: 1 time
Contact:

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby luckyst » Fri 21/11/2008 10:36 pm

1. Ok, chạy cũng tốt, có điều phải dùng điều khiển hỗ trợ unicode và phải xử lý thêm một chút cái kết quả trả về hoàn thiện (chỉ đối với dịch sang tiếng việt)
2. Lúc thì chạy ra kết quả, lúc thì ra trắng tươi (="").

Cảm ơn bạn đã chia sẽ.

User avatar
NoBi
Quản trị
Quản trị
Posts: 959
Joined: Tue 18/03/2008 1:22 pm
Location: Sài Gòn
Has thanked: 53 times
Been thanked: 66 times
Contact:

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby NoBi » Tue 25/11/2008 3:30 pm

Good, kg uổng công tui sửa lại bài viết :D.
:>

magicxhunter
Posts: 1
Joined: Mon 05/01/2009 8:25 pm

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby magicxhunter » Sun 11/01/2009 12:10 pm

Chương trình rất hay. =D>
Nhưng có cách nào cập nhật thêm danh sách dịch không? Trên Google cung cấp cả trăm kiểu dịch mà xài có mấy cái thì chưa đã. Cám ơn nhiều! :)

dactung93
Thành viên tâm huyết
Thành viên tâm huyết
Posts: 496
Joined: Tue 04/11/2008 8:43 am
Has thanked: 6 times
Been thanked: 8 times

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby dactung93 » Sun 11/01/2009 10:09 pm

Bạn có thể sử dụng cách đơn giản hơn để nâng cao số lượng ngôn ngữ bằng cách.
Đặt tên cho mỗi một combo ( giống google ý ) rồi ghép chúng lại thành một cách dịch.

HaiPT
VIP
VIP
Posts: 252
Joined: Wed 07/09/2005 4:02 pm
Location: Hải Phòng
Has thanked: 1 time
Been thanked: 12 times
Contact:

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby HaiPT » Mon 12/01/2009 12:25 am

Bài viết rất tuyệt :) , lâu rồi không đọc được bài nào hay như vậy
Phạm Hải
Quản trị dự án ,Chuyên gia đào tạo
Đại học FPT

User avatar
truongphu
VIP
VIP
Posts: 4765
Joined: Sun 04/11/2007 10:57 am
Location: Cam Đức, Khánh hòa
Has thanked: 14 times
Been thanked: 519 times

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby truongphu » Mon 12/01/2009 9:18 am

Phần mềm nầy rất tốt: đáp ứng nhanh hơn là chờ trang Google dịch.
Để hoàn thiện hơn, tôi xin edit lại code:

- loại bỏ các yếu tố thừa (theo ý tôi)
- đơn giản hóa code phần nào có thể
- bổ sung toàn bộ các ngôn ngữ hiện Google support 12/1/2009
- hoàn thiện (thêm) phần dịch tiếng Việt. (còn vài từ chưa đúng, không rõ tại sao?)
- Gởi kèm project mới

Module nhận tin

Code: Select all

  1. Option Explicit
  2.  
  3. Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
  4. Private Const INTERNET_OPEN_TYPE_DIRECT = 1
  5. Private Const INTERNET_OPEN_TYPE_PROXY = 3
  6.  
  7. Private Const scUserAgent = "VBTagEdit"
  8. Private Const INTERNET_FLAG_RELOAD = &H80000000
  9.  
  10. Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
  11. (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
  12. ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
  13.  
  14. Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _
  15. (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, _
  16. ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
  17.  
  18. Private Declare Function InternetReadFile Lib "wininet.dll" _
  19. (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _
  20. lNumberOfBytesRead As Long) As Integer
  21.  
  22. Private Declare Function InternetCloseHandle Lib "wininet.dll" _
  23. (ByVal hInet As Long) As Integer
  24.    
  25. Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
  26. (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long
  27.  
  28. Public Function GetHTMLFromURL(sUrl As String) As String
  29. Dim Str                  As String
  30. Dim hOpen              As Long
  31. Dim hOpenUrl           As Long
  32. Dim sReadBuffer        As String * 2048
  33. Dim lNumberOfBytesRead As Long
  34.  
  35. hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
  36. hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
  37.  
  38. Do
  39.     sReadBuffer = vbNullString
  40.     Call InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
  41.     Str = Str & Left$(sReadBuffer, lNumberOfBytesRead)
  42.     If Not CBool(lNumberOfBytesRead) Then Exit Do
  43. Loop
  44.  
  45. If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
  46. If hOpen <> 0 Then InternetCloseHandle (hOpen)
  47.  
  48. GetHTMLFromURL = Str
  49.  
  50. End Function
  51.  
  52. Public Function IsConnected() As Boolean
  53.  
  54.     On Error GoTo err
  55.     IsConnected = InternetGetConnectedState(0&, 0&)
  56.     Exit Function
  57.  
  58. err:     IsConnected = False
  59.  
  60. End Function
  61.  


Module dịch

Code: Select all

  1. Option Explicit
  2.  
  3. Public Function Traduction(InputText As String, LangueTrad As String) As String
  4. Const WebURL As String = "http://translate.google.com/translate_t"
  5. Const EndString As String = "</"
  6. Dim TMPString  As String
  7. Dim StartPos   As Long
  8. Dim DebString  As String
  9. Dim InitString As String
  10.  
  11. If IsConnected = False Then
  12.    MsgBox "Ban chua ket noi Internet. Hay kiem tra va lam lai!"
  13.    Traduction = ""
  14.    Exit Function
  15. End If
  16.  
  17. TMPString = GetHTMLFromURL(WebURL & "?langpair=" & LangueTrad & "&text=" & InputText)
  18.  
  19. InitString = Chr(34) & "ltr" & Chr(34) & ">"
  20.  
  21. StartPos = InStr(1, TMPString, InitString, vbTextCompare)
  22. If StartPos = 0 Then
  23.    Traduction = ""
  24.    Exit Function
  25. End If
  26.  
  27. DebString = Right(TMPString, Len(TMPString) - (StartPos + Len(InitString) - 1))
  28.  
  29. StartPos = InStr(1, DebString, EndString, vbTextCompare)
  30.  
  31. Traduction = ReplaceHTMLString(Left(DebString, StartPos - 1))
  32.  
  33. End Function
  34.  
  35. Public Function ReplaceHTMLString(InputString) As String
  36.  
  37. ReplaceHTMLString = Replace(InputString, "&#39;", "'", 1, -1, vbBinaryCompare)
  38.  
  39. End Function
  40.  


Form chính: hổ trợ tiếng Việt và mở rộng ngôn ngữ

Code: Select all

  1. Option Explicit
  2. Dim TradLang As String
  3.  
  4. Private Sub cmdCopy_Click()
  5. Clipboard.Clear
  6. Clipboard.SetText txtOutputText
  7. End Sub
  8.  
  9. Private Sub cmdTranslate_Click()
  10. txtOutputText.Text = ""
  11. Dim Vie$, i&
  12.  TradLang = Left$(Combo1.Text, 2) & "|" & Left$(Combo2.Text, 2)
  13.  Vie = Traduction(TextBox1.Text, TradLang)
  14.     For i = 1 To Len(Vie)
  15.         If Mid(Vie, i, 2) = "&#" Then
  16.             If IsNumeric(Mid(Vie, i + 2, 4)) Then
  17.                 txtOutputText.Text = txtOutputText.Text & ChrW(Mid(Vie, i + 2, 4))
  18.                 i = i + 6
  19.             Else
  20.                 txtOutputText.Text = txtOutputText.Text & ChrW(Mid(Vie, i + 2, 3))
  21.                 i = i + 5
  22.             End If
  23.        
  24.         Else
  25.             txtOutputText.Text = txtOutputText.Text & Mid(Vie, i, 1)
  26.         End If
  27.     Next
  28.  
  29. End Sub
  30.  
  31. Private Sub Form_Load()
  32.  
  33. Dim Tiêng$, Lang() As String, i%
  34. Tiêng = "ar Arabic.bg Bulgarian.ca Catalan.cs Czech.da Danish.de German.el Greek." _
  35. & "en English.es Spanish.fi Finnish.fr French.hi Hindi.hr Croatian.id Indonesian." _
  36. & "it Italian.iw Hebrew.ja Japanese.ko Korean.lt Lithuanian.lv Latvian.no Norwegian." _
  37. & "pl Polish.pt Portuguese.ro Romanian.ru Russian.sk Slovak.sl Slovenian.sr Serbian." _
  38. & "sv Swedish.tl Filipino.uk Ukrainian.vi Vietnamese.zh-CN Chinese(Simplified).zh-TW Chinese(Traditional)"
  39.   Lang = Split(Tiêng, ".")
  40. For i = 0 To UBound(Lang)
  41. Combo1.AddItem Lang(i)
  42. Combo2.AddItem Lang(i)
  43. Next
  44.  Combo1.ListIndex = 7 'English
  45.  Combo2.ListIndex = 31 'VietNamese
  46. End Sub
  47.  
Attachments
trans NEW.rar
(3.41 KiB) Downloaded 534 times
o0o--truongphu--o0o

.........
Ghé thăm:
Chuyện Linh Tinh

lachinhan
Thành viên chính thức
Thành viên chính thức
Posts: 24
Joined: Thu 16/10/2008 1:18 pm
Has thanked: 3 times

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby lachinhan » Mon 12/01/2009 9:55 am

Hay thật bác truongphu dạo này tích cực ghê, cám ơn Bác đã đóng góp cho anh em những code hay. Bác nào phát triển cái này lên thành 1 soft hay về nội dung và đẹp vì hình thức đi :D

dactung93
Thành viên tâm huyết
Thành viên tâm huyết
Posts: 496
Joined: Tue 04/11/2008 8:43 am
Has thanked: 6 times
Been thanked: 8 times

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby dactung93 » Sun 25/01/2009 3:25 am

Đây là hàm em đã sửa lại để thực hiện việc chuyển đổi chữ

Code: Select all

  1.  
  2. Function bien(chu As Variant)
  3. Dim dic
  4. For i = 1 To Len(chu)
  5.         If Mid(chu, i, 2) = "&#" Then
  6.             If IsNumeric(Mid(chu, i + 2, 4)) Then
  7.                 dic = dic & ChrW(Mid(Vie, i + 2, 4))
  8.                 i = i + 6
  9.             Else
  10.                 dic = dic & ChrW(Mid(Vie, i + 2, 3))
  11.                 i = i + 5
  12.             End If
  13.        
  14.         Else
  15.             dic = dic & Mid(Vie, i, 1)
  16.            
  17.         End If
  18.     Next
  19. bien = dic
  20. End Function
  21.  


Sử dụng thì ta chỉ cần dùng

Code: Select all

  1.  
  2. dich.Text = bien(Vie)
  3.  


Em thấy khoái dùng hàm hơn vì thỉnh thoảng lại cần dùng đến nó nhiều

User avatar
caotri270119
Thành viên chính thức
Thành viên chính thức
Posts: 30
Joined: Thu 07/08/2008 1:51 pm
Location: D2 - Bình Thạnh - Tp.HCM
Contact:

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby caotri270119 » Tue 04/08/2009 7:23 pm

mình đã down dzìa dùng thử, mình thấy rất hay đoá, nhưng mà hình như có khuyết điểm hơi lạ là sao mình dịch từ tiếng việt sang tiếng anh thì chẳng đúng tí nào. Ví dụ mình nhập vào "xin chào" thì kết quả ra là "father would o" gì đó

dactung93
Thành viên tâm huyết
Thành viên tâm huyết
Posts: 496
Joined: Tue 04/11/2008 8:43 am
Has thanked: 6 times
Been thanked: 8 times

Re: Tạo một chương trình dịch văn bản tự động qua server Google

Postby dactung93 » Fri 07/08/2009 4:48 pm

Đừng có dịch từ tiếng Việt sang các ngôn ngữ khác. Nếu muốn vậy thì đầu tiên phải mã hóa cái tiếng việt sang dạng của "Tiếng việt" mà trang google dùng để dịch ra. Kể cả tiếng Nhật hay China... ( ngôn ngữ tượng hình).

Còn làm một chương trình như Evtran thì cứ cho ngôn ngữ dịch là Auto và ngôn ngữ dịch sang là vi.
Dùng API để lấy đoạn được bôi đen và cho auto là được ngay ý mà. Cái này làm ở nhà dùng thì phê thôi rồi. Mình dùng suốt để dịch


Return to “[VB] Mẹo vặt khác”

Who is online

Users browsing this forum: No registered users and 0 guests