EDIT:
Se riferito al progetto che già abbiamo visto, metti una textbox, nel mio codice Text2, all'interno della picturebox, il progetto completo diventa:


Private Declare Function InternetOpen Lib "WININET" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "WININET" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "WININET" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "WININET" (ByVal hInet As Long) As Integer
Private Declare Function DeleteUrlCacheEntry Lib "WININET" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Dim pushpin_0_x As Integer
Dim pushpin_0_y As Integer
Dim pushpin_1_x As Integer
Dim pushpin_1_y As Integer
Dim coordinate_0 As String
Dim coordinate_1 As String

Private Sub Form_Load()
    carica_sito ("http://dev.virtualearth.net/REST/v1/Imagery/Map/Road/Routes?wp.0=37,3107,13,5766;3;AGRIGENTO&wp.1=43,4628,11,8807;9;AREZZO&mapsize=640,480&C=IT&mapMetadata=1&format=jpeg&key=Ap94-koskdt-HryTYKhaJf5GLnuzjt3uLkl5AyKQnIYw6m6QPmiDIxJSWW_1AJ_1")
    Picture1.Picture = LoadPicture(App.Path & "\MappaArezzoAgrigento.bmp")
    Form1.ScaleMode = 3
    Picture1.ScaleMode = 3
    Text2.Appearance = 0
    Text2.BackColor = vbYellow
    Text2.Visible = False
End Sub

Public Sub carica_sito(url)
  
    Dim hOpen               As Long
    Dim hOpenUrl            As Long
    Dim sURL                As String
    Dim bDoLoop             As Boolean
    Dim bRet                As Boolean
    Dim sReadBuffer         As String * 2048
    Dim lNumberOfBytesRead  As Long
    sBuffer = ""
    sURL = url
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    hOpenUrl = InternetOpenUrl(hOpen, sURL, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
    bDoLoop = True
    While bDoLoop
        DoEvents
        sReadBuffer = vbNullString
        bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
        sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
        If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
    Wend
    If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
    Text1.Text = sBuffer
    Call Interpreta(CStr(sBuffer))
 
End Sub
    
Private Sub Interpreta(json As String)

    Dim pos1 As Long
    Dim pos2 As Long
 
    pos1 = 1
   
    pos1 = InStr(pos1, json, "coordinates", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "]", vbTextCompare)
    List1.AddItem ("coordinate centro mappa: " & Mid(json, pos1 + 13, pos2 - pos1 - 12))
    
    pos1 = InStr(pos2, json, "pushpin", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "}", vbTextCompare)
   
    Dim pushpin_0 As String
    pushpin_0 = Mid(json, pos1 + 22, pos2 - pos1 - 22)
    List1.AddItem ("pushpin_0: " & pushpin_0)
    
    pos1 = InStr(pos2, json, "coordinates", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "]", vbTextCompare)
    coordinate_0 = Mid(json, pos1 + 13, pos2 - pos1 - 12)
    List1.AddItem ("coordinate_0: " & coordinate_0)
    
    pos1 = InStr(pos2, json, "anchor", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "}", vbTextCompare)
    
    Dim pushpin_1 As String
    pushpin_1 = Mid(json, pos1 + 9, pos2 - pos1 - 9)
    List1.AddItem ("pushpin_1: " & pushpin_1)
    
    pos1 = InStr(pos2, json, "coordinates", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "]", vbTextCompare)
    coordinate_1 = Mid(json, pos1 + 13, pos2 - pos1 - 12)
    List1.AddItem ("coordinate_1: " & coordinate_1)
    
    pos1 = InStr(1, pushpin_0, ":""", vbTextCompare)
    pos2 = InStr(pos1, pushpin_0, """,", vbTextCompare)
    pushpin_0_x = CInt(Mid(pushpin_0, pos1 + 2, pos2 - pos1 - 2))
    List1.AddItem ("pushpin_0_x = " & pushpin_0_x)
    
    pos1 = InStr(pos2 + 2, pushpin_0, ":""", vbTextCompare)
    pos2 = InStr(pos1 + 2, pushpin_0, """", vbTextCompare)
    pushpin_0_y = CInt(Mid(pushpin_0, pos1 + 2, pos2 - pos1 - 2))
    List1.AddItem ("pushpin_0_y = " & pushpin_0_y)
    
    pos1 = InStr(1, pushpin_1, ":""", vbTextCompare)
    pos2 = InStr(pos1, pushpin_1, """,", vbTextCompare)
    pushpin_1_x = CInt(Mid(pushpin_1, pos1 + 2, pos2 - pos1 - 2))
    List1.AddItem ("pushpin_1_x = " & pushpin_1_x)
    
    pos1 = InStr(pos2 + 2, pushpin_1, ":""", vbTextCompare)
    pos2 = InStr(pos1 + 2, pushpin_1, """", vbTextCompare)
    pushpin_1_y = CInt(Mid(pushpin_1, pos1 + 2, pos2 - pos1 - 2))
    List1.AddItem ("pushpin_1_y = " & pushpin_1_y)

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    If X > pushpin_1_x - 7 And X < pushpin_1_x + 7 And Y > pushpin_1_y - 15 And Y < pushpin_1_y - 4 Then
        Text2.Top = pushpin_1_y - 10
        Text2.Left = pushpin_1_x + 20
        Text2.Text = coordinate_1
        Text2.Visible = True
    ElseIf X > pushpin_0_x - 7 And X < pushpin_0_x + 7 And Y > pushpin_0_y - 15 And Y < pushpin_0_y - 4 Then
        Text2.Top = pushpin_0_y - 10
        Text2.Left = pushpin_0_x + 20
        Text2.Text = coordinate_0
        Text2.Visible = True
    Else
        Text2.Visible = False
    End If
End Sub

luca90

Utente Attivo

Iscritto da: ott, 2012

Messaggi:: 99

Re: TOOLTIP con mousemove

26 dic 2020, 19:09

Rubik ha scritto:

EDIT:
Se riferito al progetto che già abbiamo visto, metti una textbox, nel mio codice Text2, all'interno della picturebox, il progetto completo diventa:


Private Declare Function InternetOpen Lib "WININET" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "WININET" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "WININET" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "WININET" (ByVal hInet As Long) As Integer
Private Declare Function DeleteUrlCacheEntry Lib "WININET" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Dim pushpin_0_x As Integer
Dim pushpin_0_y As Integer
Dim pushpin_1_x As Integer
Dim pushpin_1_y As Integer
Dim coordinate_0 As String
Dim coordinate_1 As String

Private Sub Form_Load()
    carica_sito ("http://dev.virtualearth.net/REST/v1/Imagery/Map/Road/Routes?wp.0=37,3107,13,5766;3;AGRIGENTO&wp.1=43,4628,11,8807;9;AREZZO&mapsize=640,480&C=IT&mapMetadata=1&format=jpeg&key=Ap94-koskdt-HryTYKhaJf5GLnuzjt3uLkl5AyKQnIYw6m6QPmiDIxJSWW_1AJ_1")
    Picture1.Picture = LoadPicture(App.Path & "\MappaArezzoAgrigento.bmp")
    Form1.ScaleMode = 3
    Picture1.ScaleMode = 3
    Text2.Appearance = 0
    Text2.BackColor = vbYellow
    Text2.Visible = False
End Sub

Public Sub carica_sito(url)
  
    Dim hOpen               As Long
    Dim hOpenUrl            As Long
    Dim sURL                As String
    Dim bDoLoop             As Boolean
    Dim bRet                As Boolean
    Dim sReadBuffer         As String * 2048
    Dim lNumberOfBytesRead  As Long
    sBuffer = ""
    sURL = url
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    hOpenUrl = InternetOpenUrl(hOpen, sURL, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
    bDoLoop = True
    While bDoLoop
        DoEvents
        sReadBuffer = vbNullString
        bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
        sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
        If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
    Wend
    If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
    Text1.Text = sBuffer
    Call Interpreta(CStr(sBuffer))
 
End Sub
    
Private Sub Interpreta(json As String)

    Dim pos1 As Long
    Dim pos2 As Long
 
    pos1 = 1
   
    pos1 = InStr(pos1, json, "coordinates", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "]", vbTextCompare)
    List1.AddItem ("coordinate centro mappa: " & Mid(json, pos1 + 13, pos2 - pos1 - 12))
    
    pos1 = InStr(pos2, json, "pushpin", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "}", vbTextCompare)
   
    Dim pushpin_0 As String
    pushpin_0 = Mid(json, pos1 + 22, pos2 - pos1 - 22)
    List1.AddItem ("pushpin_0: " & pushpin_0)
    
    pos1 = InStr(pos2, json, "coordinates", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "]", vbTextCompare)
    coordinate_0 = Mid(json, pos1 + 13, pos2 - pos1 - 12)
    List1.AddItem ("coordinate_0: " & coordinate_0)
    
    pos1 = InStr(pos2, json, "anchor", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "}", vbTextCompare)
    
    Dim pushpin_1 As String
    pushpin_1 = Mid(json, pos1 + 9, pos2 - pos1 - 9)
    List1.AddItem ("pushpin_1: " & pushpin_1)
    
    pos1 = InStr(pos2, json, "coordinates", vbTextCompare)
    pos2 = InStr(pos1 + 1, json, "]", vbTextCompare)
    coordinate_1 = Mid(json, pos1 + 13, pos2 - pos1 - 12)
    List1.AddItem ("coordinate_1: " & coordinate_1)
    
    pos1 = InStr(1, pushpin_0, ":""", vbTextCompare)
    pos2 = InStr(pos1, pushpin_0, """,", vbTextCompare)
    pushpin_0_x = CInt(Mid(pushpin_0, pos1 + 2, pos2 - pos1 - 2))
    List1.AddItem ("pushpin_0_x = " & pushpin_0_x)
    
    pos1 = InStr(pos2 + 2, pushpin_0, ":""", vbTextCompare)
    pos2 = InStr(pos1 + 2, pushpin_0, """", vbTextCompare)
    pushpin_0_y = CInt(Mid(pushpin_0, pos1 + 2, pos2 - pos1 - 2))
    List1.AddItem ("pushpin_0_y = " & pushpin_0_y)
    
    pos1 = InStr(1, pushpin_1, ":""", vbTextCompare)
    pos2 = InStr(pos1, pushpin_1, """,", vbTextCompare)
    pushpin_1_x = CInt(Mid(pushpin_1, pos1 + 2, pos2 - pos1 - 2))
    List1.AddItem ("pushpin_1_x = " & pushpin_1_x)
    
    pos1 = InStr(pos2 + 2, pushpin_1, ":""", vbTextCompare)
    pos2 = InStr(pos1 + 2, pushpin_1, """", vbTextCompare)
    pushpin_1_y = CInt(Mid(pushpin_1, pos1 + 2, pos2 - pos1 - 2))
    List1.AddItem ("pushpin_1_y = " & pushpin_1_y)

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    If X > pushpin_1_x - 7 And X < pushpin_1_x + 7 And Y > pushpin_1_y - 15 And Y < pushpin_1_y - 4 Then
        Text2.Top = pushpin_1_y - 10
        Text2.Left = pushpin_1_x + 20
        Text2.Text = coordinate_1
        Text2.Visible = True
    ElseIf X > pushpin_0_x - 7 And X < pushpin_0_x + 7 And Y > pushpin_0_y - 15 And Y < pushpin_0_y - 4 Then
        Text2.Top = pushpin_0_y - 10
        Text2.Left = pushpin_0_x + 20
        Text2.Text = coordinate_0
        Text2.Visible = True
    Else
        Text2.Visible = False
    End If
End Sub

BingMap.gif

Mi hai letto nel pensiero!
Grazie. Posso provare solo domani, ti faccio sapere.
Buon Natale!

luca90

Utente Attivo

Iscritto da: ott, 2012

Messaggi:: 99

test fatto! SPETTACOLARE!!!!

Per rendere più simpatico il progetto, invece della label che fa da tooltip, si può fare con un Ballon Multiline?
io uso una classe ma per le listview... (https://www.freevbcode.com/ShowCode.asp?ID=571)

Rubik

Utente Attivo

Iscritto da: ago, 2020

Messaggi:: 440

Re: TOOLTIP con mousemove

28 dic 2020, 20:11

Tutto si può fare, ma ricorda che stai usando VB6, è da molto che non lo uso, le soluzioni semplici che mi vengono in mente sono per VB.Net, in VB6 ricordo che usavo i Form ritagliati, ma ora non mi torna in mente come.
Se sei alle prime armi e devi imparare, meglio usare il tempo con VB.Net.
VB6 ancora esiste per quei progetti non migrabili, che devono ancora essere mantenuti in funzione, se stai imparando meglio imparare in un linguaggio che ha molte più possibilità, cose difficili da fare in VB6 sono semplici in VB.Net o C#.
EDIT: ho ritrovato uno spezzone di codice VB6 messo da parte, al form devi aggiungere 8 pulsanti che cambieranno la dimensione del ritaglio.


Option Explicit
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long


Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
ByVal Y2 As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" _
(ByVal hWnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long

Private Sub Command1_Click()
a = a + 1
Command1.Caption = CStr(a)
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

Private Sub Command2_Click()
b = b + 1
Command2.Caption = CStr(b)
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

Private Sub Command3_Click()
c = c + 1
Command3.Caption = CStr(c)
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

Private Sub Command4_Click()
d = d + 1
Command4.Caption = CStr(d)
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

Private Sub Command5_Click()
a = a - 1
Command1.Caption = CStr(a)
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

Private Sub Command6_Click()
b = b - 1
Command2.Caption = CStr(b)
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

Private Sub Command7_Click()
c = c - 1
Command3.Caption = CStr(c)
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

Private Sub Command8_Click()
d = d - 1
Command4.Caption = CStr(d)
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

Private Sub Form_Load()
a = -59
b = -59
c = 441
d = 346
'Show The form!
SetWindowRgn hWnd, CreateEllipticRgn(a, b, c, d), True
End Sub

In VB.Net c'e il TrasparenceKey, basta colorare l'area del form che si vuole trasparente con il colore scelto nel TrasparenceKey e risolvi con una riga di codice.

L
luca90
Utente Attivo
Iscritto da
ott, 2012
Messaggi:
99
Re: TOOLTIP con mousemove
28 dic 2020, 20:21
Rubik ha scritto:
Tutto si può fare, ma ricorda che stai usando VB6, è da molto che non lo uso, le soluzioni semplici che mi vengono in mente sono per VB.Net, in VB6 ricordo che usavo i Form ritagliati, ma ora non mi torna in mente come.
Peccato, sarebbe stato bello.
In ogni caso se ti dovesse venire in mente qualcosa.....
Grazie sempre per la tua disponibilità.
Rubik
Utente Attivo
Iscritto da
ago, 2020
Messaggi:
440
Re: TOOLTIP con mousemove
28 dic 2020, 20:23
luca90 ha scritto:

Rubik ha scritto:
Tutto si può fare, ma ricorda che stai usando VB6, è da molto che non lo uso, le soluzioni semplici che mi vengono in mente sono per VB.Net, in VB6 ricordo che usavo i Form ritagliati, ma ora non mi torna in mente come.
Peccato, sarebbe stato bello.
In ogni caso se ti dovesse venire in mente qualcosa.....
Grazie sempre per la tua disponibilità.
abbiamo risposto insieme, guarda sopra.

Devi accedere o registrarti per scrivere nel forum

6 risposte