Application.FollowHyperlink MapSearch

[ΚΩΣΤΑΣ2]

Χαιρετώ όλο το Forum που είναι το καλλίτερο φροντιστήριο που υπάρχει

επανέρχομαι στο θέμα Application.FollowHyperlink MyHyperlink
επειδή δεν αποκωδικοποιούνται τα ελληνικά στη Google Map
έκανα ένα τέχνασμα χρησιμοποίησα το CODE του Tassos Filoxenidis - Forum - ms-office.gr

CODE
Option Compare Database

Option Explicit

Public Const EVChars = "914,915,916,918,924,925,929,913,917,919,921,927,9 33,937"
Public Const EFChars = "920,922,926,928,931,932,934,935"
Public Const DummyChar = "?"

'Autor: Tassos Filoxenidis - Forum - ms-office.gr

Public Function Transliterate(ByRef strChars As String, _
Optional ByVal strCharslength As Integer, _
Optional ByRef AutoCompleteChar As String) As String

Dim i As Integer, strChar As String, OldCharsLen As Integer, _
strCharsLen As Integer, SecChar As Integer

If Trim(AutoCompleteChar) = vbNullString Then AutoCompleteChar = DummyChar
strChars = ReplaceTones(strChars)

OldCharsLen = Len(strChars)

If strCharslength = 0 Then strCharslength = OldCharsLen

If Len(strChars) < strCharslength Then
strChars = strChars & String(strCharslength - Len(strChars), AutoCompleteChar)
End If
strCharsLen = Len(strChars)

For i = 1 To strCharsLen
Select Case AscW(Mid(strChars, i, 1))

Case 913 'Alpha
If i < strCharslength Then
If AscW(Mid(strChars, i + 1, 1)) = 933 Then
If i + 2 > OldCharsLen Then
SecChar = 0
Else
SecChar = AscW(Mid(strChars, i + 2, 1))
End If
If InStr(1, EVChars, SecChar) > 0 Then
strChar = strChar & "AV"
i = i + 1
ElseIf InStr(1, EFChars, SecChar) > 0 Or Right(strChars, 1) = SecChar Then
strChar = strChar & "AF"
i = i + 1
Else
strChar = strChar & "A"
End If
Else
strChar = strChar & "A"
End If
Else
strChar = strChar & "A"
End If

Case 914 'Beta
strChar = strChar & "B"

Case 915 'Gama
If i < strCharslength Then
If AscW(Mid(strChars, i + 1, 1)) = 915 Then
strChar = strChar & "NG"
i = i + 1
ElseIf AscW(Mid(strChars, i + 1, 1)) = 922 Then
strChar = strChar & "GK"
i = i + 1
Else
strChar = strChar & "G"
End If
Else
strChar = strChar & "G"
End If

Case 916 'Delta
strChar = strChar & "D"

Case 917 'Epsilon

If i < strCharslength Then
If AscW(Mid(strChars, i + 1, 1)) = 933 Then
If i + 2 > OldCharsLen Then
SecChar = 0
Else
SecChar = AscW(Mid(strChars, i + 2, 1))
End If
If InStr(1, EVChars, SecChar) > 0 Then
strChar = strChar & "EV"
i = i + 1
ElseIf InStr(1, EFChars, SecChar) > 0 Or Right(strChars, 1) = SecChar Then
strChar = strChar & "EF"
i = i + 1
Else
strChar = strChar & "E"
End If

Else
strChar = strChar & "E"
End If
Else
strChar = strChar & "E"
End If

Case 918 'Zeta
strChar = strChar & "Z"

Case 919 'Eta

If i < strCharslength Then
If AscW(Mid(strChars, i + 1, 1)) = 933 Then
If i + 2 > OldCharsLen Then
SecChar = 0
Else
SecChar = AscW(Mid(strChars, i + 2, 1))
End If
If InStr(1, EVChars, SecChar) > 0 Then
strChar = strChar & "IY"
i = i + 1
ElseIf InStr(1, EFChars, SecChar) > 0 Or Right(strChars, 1) = SecChar Then
strChar = strChar & "IF"
i = i + 1
Else
strChar = strChar & "I"
End If
Else
strChar = strChar & "I"
End If
Else
strChar = strChar & "I"
End If

Case 920 'Theta
strChar = strChar & "TH"

Case 921 'Iota
strChar = strChar & "I"

Case 922 'Kappa
strChar = strChar & "K"

Case 923 'Lambda
strChar = strChar & "L"

Case 924 'Mu
If i < strCharslength Then
If AscW(Mid(strChars, i + 1, 1)) = 928 Then
If i > 1 And i + 1 < OldCharsLen Then
strChar = strChar & "MP"
i = i + 1

Else
strChar = strChar & "B"
i = i + 1
End If
Else
strChar = strChar & "M"
End If
Else
strChar = strChar & "I"
End If

Case 925 'Nu
If i < strCharslength Then
If AscW(Mid(strChars, i + 1, 1)) = 932 Then
strChar = strChar & "NT"
i = i + 1
Else
strChar = strChar & "N"
End If
Else
strChar = strChar & "I"
End If

Case 926 'Xi
strChar = strChar & "X"

Case 927 'Omicron
If i < strCharslength Then
If AscW(Mid(strChars, i + 1, 1)) = 933 Then
strChar = strChar & "OU"
i = i + 1
Else
strChar = strChar & "O"
End If
Else
strChar = strChar & "O"
End If

Case 928 'Pi
strChar = strChar & "P"

Case 929 'Rho
strChar = strChar & "R"

Case 931 'Sigma
strChar = strChar & "S"

Case 932 'Tau
strChar = strChar & "T"

Case 933 'Upsilon
strChar = strChar & "Y"

Case 934 'Phi
strChar = strChar & "F"

Case 935 'Chi
strChar = strChar & "CH"
If Len(strChar) >= strCharslength Then strCharslength = strCharslength + 1
Case 936 'Psi
strChar = strChar & "PS"
If Len(strChar) >= strCharslength Then strCharslength = strCharslength + 1
Case 937 'Omega
strChar = strChar & "O"

Case Else
strChar = strChar & Mid(strChars, i, 1)
End Select
If Len(strChar) >= strCharslength Then
' strCharslength = strInitialLength
Exit For
End If
Next
If AutoCompleteChar <> DummyChar Then
If Len(strChar) < strCharslength Then
strChar = strChar & String(strCharslength - Len(strChar), AutoCompleteChar)
End If
Else
strChar = Replace(strChar, DummyChar, vbNullString)
End If
Transliterate = strChar
End Function

Function ReplaceTones(strChar As String) As String
ReplaceTones = UCase$(strChar)
ReplaceTones = Replace(ReplaceTones, ChrW$(902), ChrW$(913))
ReplaceTones = Replace(ReplaceTones, ChrW$(904), ChrW$(917))
ReplaceTones = Replace(ReplaceTones, ChrW$(906), ChrW$(921))
ReplaceTones = Replace(ReplaceTones, ChrW$(938), ChrW$(921))
ReplaceTones = Replace(ReplaceTones, ChrW$(905), ChrW$(919))
ReplaceTones = Replace(ReplaceTones, ChrW$(910), ChrW$(933))
ReplaceTones = Replace(ReplaceTones, ChrW$(939), ChrW$(933))
ReplaceTones = Replace(ReplaceTones, ChrW$(908), ChrW$(927))
ReplaceTones = Replace(ReplaceTones, ChrW$(911), ChrW$(937))
ReplaceTones = Replace(ReplaceTones, ChrW$(962), ChrW$(931))
End Function


και στη δικια μου περίπτωση τρέχει άψογα 2 μήνες τώρα


Private Sub cmdShowMap_Click()
Dim MapSearch As String
Dim strAddress As String
strAddress = Transliterate(Nz([ΟΔΟΣ]) & "," & Nz([ΚΩΔ_ΠΕΡ]) & "," & Nz([ΤΑΧ_ΚΩΔΙΚΟΣ])) & ""
MapSearch = "http://maps.google.com/maps?hl=el&q=" & strAddress
Application.FollowHyperlink MapSearch
End Sub

οποιαδήποτε υπόδειξη είναι δεκτη
σας ευχαριστώ