VB & HTML

[killerb]

Я пишу программу-агент, которая будет сидеть в трее и 1 раз в минуту просматривать почту. В случае наличия новой почты на сервере она должна загружать текст и выводить его в Балоновую подсказку.
Проблема заключаеться в том, что я не знаю как "очистить" текст от html-тегов. Иными словами я хочу гипертекст превратить в обычный. Я уже часа 2 провел в безрезультатных попытках написать алогоритм "очищения". Пожалуйста помогите!

[kirrun]

Написал за 3 минуты

Код: Выделить всё

Private Function anti_html (ByVal html_text as String)
While InStr(1, html_text, "<") Or InStr(1, html_text, ">")
    a = InStr(1, html_text, "<")
    t = Left(html_text, a - 1)
    a = InStr(1, html_text, ">")
    t = t & Right(html_text, Len(html_text) - a)
    html_text = t
Wend
anti_html = html_text
End Function


[kirrun]

ЗЫ. Код работать будет только с ПРАВИЛЬНЫМ html-кодом. То есть Если будет например тег "html>" или "<html" то вылетит с ошибкой. Что внутри тега - однофигственно тк удаляется все от "<" и до ">"

Накидал так просто, как попало, так что неплохо бы дописать...

[killerb]

Большое спасибо !

[Akella]

killerb, скажи пожалуйста как сделать "Балоновую подсказку".
или еще лутче выложи ее кодик

[Александр80]

Мне тоже интересно... Конечно можно и через агента, но наверняка есть и другой способ...? Я прав?

[Igor_123]

Дык, эта! Было обсуждение того, что такая подсказка не висит положенное время. В обсуждении выкладывался код создания такой подсказки. Поищите.

[killerb]

Баллоновая подсказка

Форма

Код: Выделить всё

Private Sub Form_Load()
Set cTray = New TrayIconAndBalloon
End Sub
Private Sub Command1_Click()
Balloon "Заголовок", "Текст"
End Sub
Private Sub Balloon(ByVal Title As String, Text As String)
    cTray.DisplayBalloon Title, Text, NIIF_INFO
End Sub


Модуль класса с именем TrayIconAndBalloon

Код: Выделить всё

Option Explicit
'-------------------------------------------------
Private Const NOTIFYICON_VERSION = &H3
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_NULL = &H0

Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIM_SETFOCUS = &H3
Private Const NIM_SETVERSION = &H4
Private Const NIM_VERSION = &H5

Private Const NIS_HIDDEN = &H1
Private Const NIS_SHAREDICON = &H2

   
Private Const WM_USER = &H400
Private Const NIN_BALLOONSHOW = (WM_USER + 2)
Private Const NIN_BALLOONHIDE = (WM_USER + 3)
Private Const NIN_BALLOONTIMEOUT = (WM_USER + 4)
Private Const NIN_BALLOONUSERCLICK = (WM_USER + 5)

'shell version / NOTIFIYICONDATA struct size constants
Private Const NOTIFYICONDATA_V1_SIZE As Long = 88  'pre-5.0 structure size
Private Const NOTIFYICONDATA_V2_SIZE As Long = 488 'pre-6.0 structure size
Private Const NOTIFYICONDATA_V3_SIZE As Long = 504 '6.0+ structure size
Private NOTIFYICONDATA_SIZE As Long

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

Private Type NOTIFYICONDATA
  cbSize As Long
  hwnd As Long
  uID As Long
  uFlags As Long
  uCallbackMessage As Long
  hIcon As Long
  szTip As String * 128
  dwState As Long
  dwStateMask As Long
  szInfo As String * 256
  uTimeoutAndVersion As Long
  szInfoTitle As String * 64
  dwInfoFlags As Long
  guidItem As GUID
End Type
'-----------------------------------------------------
'-----------------------------------------------------
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _
   Alias "Shell_NotifyIconA" _
  (ByVal dwMessage As Long, _
   lpData As NOTIFYICONDATA) As Long

Private Declare Function GetFileVersionInfoSize Lib "version.dll" _
   Alias "GetFileVersionInfoSizeA" _
  (ByVal lptstrFilename As String, _
   lpdwHandle As Long) As Long

Private Declare Function GetFileVersionInfo Lib "version.dll" _
   Alias "GetFileVersionInfoA" _
  (ByVal lptstrFilename As String, _
   ByVal dwHandle As Long, _
   ByVal dwLen As Long, _
   lpData As Any) As Long
   
Private Declare Function VerQueryValue Lib "version.dll" _
   Alias "VerQueryValueA" _
  (pBlock As Any, _
   ByVal lpSubBlock As String, _
   lpBuffer As Any, _
   nVerSize As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, _
   Source As Any, _
   ByVal Length As Long)

Private Declare Function SetForegroundWindow Lib "user32" _
    (ByVal hwnd As Long) As Long

Private Declare Function PostMessage Lib "user32" _
    Alias "PostMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long

'---------------------------------------------------------------------

'ïåðåìåííûå è ñòðóêòóðû ìîäóëÿ
   Private NID              As NOTIFYICONDATA
   Private m_hWnd           As Long
   Private m_Icon           As Long
   Private m_ToolTipText    As String
   Public Enum TrayIcon_InfoIcon
        NIIF_NONE = &H0
        NIIF_INFO = &H1
        NIIF_WARNING = &H2
        NIIF_ERROR = &H3
        NIIF_GUID = &H5         ' Íå èñïîëüçóåòñÿ
        NIIF_ICON_MASK = &HF    ' Íå èñïîëüçóåòñÿ
        NIIF_NOSOUND = &H10
   End Enum
   Public Enum TrayIcon_Mouse
        TRAYICON_MOUSE_NONE = 0
        TRAYICON_MOUSE_LEFTDOWN = 1
        TRAYICON_MOUSE_LEFTUP = 2
        TRAYICON_MOUSE_LEFTDBLCLICK = 3
        TRAYICON_MOUSE_RIGHTDOWN = 4
        TRAYICON_MOUSE_RIGHTUP = 5
        TRAYICON_MOUSE_RIGHTDBLCLICK = 6
   End Enum

'èâåíòû
   Public Event OnIcon(MouseButton As Integer)

'---------------------------------------------------------------------
'  Ñâîéñòâà

'ïîëó÷èòü ñâîéñòâî hWnd
Public Property Get hwnd() As Long
      hwnd = m_hWnd
End Property

'ïðèñâîèòü ñâîéñòâî hWnd
Public Property Let hwnd(ByVal NewValue As Long)
      m_hWnd = NewValue
End Property

'ïîëó÷èòü ñâîéñòâî Icon
Public Property Get Icon() As Long
      Icon = m_Icon
End Property

'ïðèñâîèòü ñâîéñòâî Icon
Public Property Let Icon(ByVal NewValue As Long)
      m_Icon = NewValue
End Property


'ïîëó÷èòü ñâîéñòâî ToolTipText
Public Property Get ToolTipText() As String
      ToolTipText = m_ToolTipText
End Property

'ïðèñâîèòü ñâîéñòâî ToolTipText
Public Property Let ToolTipText(ByVal NewValue As String)
      m_ToolTipText = NewValue
End Property

'---------------------------------------------------------------------
'  Ìåòîäû

'äîáàâëåíèå èêîíêè â Tray
Public Sub Add()
   Dim ret As Long
   If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
   'çàïîëíÿåì ñòðóêòóðó
   With NID
      .uID = m_hWnd
      .hwnd = m_hWnd
      .hIcon = m_Icon
      .szTip = Left$(m_ToolTipText, 63) & Chr$(0)
      .uFlags = NIF_TIP + NIF_MESSAGE + NIF_ICON
      .uCallbackMessage = WM_RBUTTONDOWN
      .cbSize = NOTIFYICONDATA_SIZE
      .uTimeoutAndVersion = NOTIFYICON_VERSION
    End With
   'âûçûâàåì ôóíêöèþ API
      ret = Shell_NotifyIcon(NIM_ADD, NID)
   'Èôîðìèðóåì ñèñòåìó î íîâîé èêîíêå
      ret = Shell_NotifyIcon(NIM_SETVERSION, NID)
End Sub

'èçìåíåíèå èêîíêè è ToolTip â Tray
Public Sub Modify()
   Dim ret As Long
   'çàïîëíÿåì ñòðóêòóðêó
    With NID
      .hIcon = m_Icon
      .szTip = Left$(m_ToolTipText, 63) & Chr$(0)
      .uFlags = NIF_TIP + NIF_ICON
      .cbSize = Len(NID)
    End With
   'âûçûâàåì ôóíêöèþ API
      ret = Shell_NotifyIcon(NIM_MODIFY, NID)
End Sub

' âûâîä âñïëûâàþùåãî ñîîáùåíèÿ
Public Sub DisplayBalloon(ByVal sTitle As String, ByVal sText As String, Optional ByVal InfoFlags As TrayIcon_InfoIcon)
Dim ret As Long
If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion
   With NID
      .cbSize = NOTIFYICONDATA_SIZE
      .hwnd = m_hWnd
      .uID = m_hWnd
      .uFlags = NIF_INFO
      .dwInfoFlags = InfoFlags
      .szInfoTitle = sTitle & vbNullChar
      .szInfo = sText & vbNullChar
   End With
   ret = Shell_NotifyIcon(NIM_MODIFY, NID)
End Sub

'óäàëåíèå èêîíêè èç Tray
Public Sub Delete()
   Dim ret As Long
   'çàïîëíÿåì ñòðóêòóðêó
      NID.cbSize = Len(NID)
   'âûçûâàåì ôóíêöèþ API
      ret = Shell_NotifyIcon(NIM_DELETE, NID)
End Sub


'âûçâàòü èâåíò
Public Sub CallEvent(X As Single, Y As Single)
   'ïðîâåðêà, áûëî ëè äåéñòâèå ïî îêíó èëè ïî èêîíêå â òðåå
      If Y Then Exit Sub
   'ïîëó÷àåì òèï äåéñòâèÿ
      Dim MouseButton As Integer
      MouseButton = (X And &HFF) / Screen.TwipsPerPixelX
   'ãåíåðèðóåì ñîáûòûå
      RaiseEvent OnIcon(MouseButton)
End Sub

'âûçîâ âñïëûâàþùåãî ìåíþ
Public Sub CallPopupMenu(Window As Form, PopMenu As Menu, Optional Flags, Optional X, Optional Y, Optional DefMenu)
   'óñòàíàâëèâàåì îêíî
      SetForegroundWindow m_hWnd
   'âûâîäèì âñïëûâàþùåå ìåíþ
      Window.PopupMenu PopMenu, Flags, X, Y, DefMenu
   'ïîñûëàåì ñîîáùåíèå îêíó
      PostMessage m_hWnd, WM_NULL, 0, 0
End Sub

Private Sub SetShellVersion()
   Select Case True
      Case IsShellVersion(6)
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE '6.0+ structure size
      Case IsShellVersion(5)
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE 'pre-6.0 structure size
      Case Else
         NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE 'pre-5.0 structure size
   End Select
End Sub

'Îïðåäåëÿåì âåðñèþ îáîëî÷êè Shell32.dll
Private Function IsShellVersion(ByVal version As Long) As Boolean
   Dim nBufferSize As Long, nUnused As Long, lpBuffer As Long, nVerMajor As Integer, bBuffer() As Byte
   Const sDLLFile As String = "shell32.dll"
   nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)
   If nBufferSize > 0 Then
      ReDim bBuffer(nBufferSize - 1) As Byte
      Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))
      If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then
         CopyMemory nVerMajor, ByVal lpBuffer + 10, 2
         IsShellVersion = nVerMajor >= version
      End If
   End If
End Function


Вроде должно работать...

[killerb]

Вот готовый пример, в котором реализована работа с треем, в том числе балоновой подсказкой.

[SnAIper]

ЗЫ. Код работать будет только с ПРАВИЛЬНЫМ html-кодом. То есть Если будет например тег "html>" или "<html" то вылетит с ошибкой. Что внутри тега - однофигственно тк удаляется все от "<" и до ">"

Хм... Я вот тоже задался этой целью... Но моя процедура всё чистит, да-да Рассчёт на то, что все <> введённые юзером система заменит на спецсимволы, а они восстановятся до нормальных <> следующей процедурой. Работает, я и не мучился с этим <примитивным> алгоритмом более 10 минут

Код: Выделить всё

Public Function StripTags(ByVal st As String) As String
'Вырезаем из текста теги и гребаные стили...
  Dim i As Long
  Dim f1, f2 As Boolean
  Dim rez As String
  i = 0
  f1 = False
  f2 = False
  rez = ""
  For i = 1 To Len(st)
    If (Mid(st, i, 1) = "<") Then
      f1 = True
    ElseIf (Mid(st, i, 1) = ">") Then
      f1 = False
    ElseIf (Mid(st, i, 1) = "{") Then
      f2 = True
    ElseIf (Mid(st, i, 1) = "}") Then
      f2 = False
    End If
 
    If Not (f1 Or f2) And (Mid(st, i, 1) <> ">") And (Mid(st, i, 1) <> "}") Then
      If (Asc(Mid(st, i, 1)) <> 10) And (Asc(Mid(st, i, 1)) <> 13) Then
        rez = rez + Mid(st, i, 1)
      Else
       If (Len(rez) > 2) Then If (Asc(right(rez, 1)) <> 10) And (Asc(Mid(rez, Len(rez) - 2, 1)) <> 13) Then rez = rez + vbCrLf
      End If
    End If
Next i
i = 1
Do While (Mid(rez, i, 1) = Chr(10)) Or (Mid(rez, i, 1) = Chr(13)) Or (Mid(rez, i, 1) = vbCr) Or (Mid(rez, i, 1) = vbLf)
i = i + 1
Loop
rez = right(rez, Len(rez) - i + 1)
StripTags = rez
End Function

И восстановление:

Код: Выделить всё

Public Function EncryptText(ByVal st As String) As String
'Чиним чатовские закидоны до нормальных символов...
'НИ В КОЕМ СЛУЧАЕ не применять к этой функции СтрипТэгс
'  - порежет что надо и что не надо :D
  Dim i As Long
  Dim rez As String
  i = 1
  rez = ""
  Do While i <= Len(st)
    If (Mid(st, i, 4) = "&gt;") Then
      rez = rez + ">"
      i = i + 4
    ElseIf (Mid(st, i, 4) = "&lt;") Then
      rez = rez + "<"
      i = i + 4
    ElseIf (Mid(st, i, 6) = "&quot;") Then
      rez = rez + Chr(34)
      i = i + 6
    ElseIf (Mid(st, i, 6) = "&nbsp;") Then
      rez = rez + " "
      i = i + 6
    ElseIf (Mid(st, i, 5) = "&amp;") Then
      rez = rez + "&"
      i = i + 5
    ElseIf (Mid(st, i, 5) = "&shy;") Then
      rez = rez + "-"
      i = i + 5
    Else
     rez = rez + Mid(st, i, 1)
     i = i + 1
    End If
  Loop
  EncryptText = rez
End Function


Код: Выделить всё

Do While Not EOF(1)
  Line Input #1, s
  txt = txt + StripTags(s)
Loop
txt = EncryptText(txt)


И вроде всё. Если это лог чата или текст форума - можно подавать на формочку. Если это профиль юзера - можно распихать его по полям датабазы, вроде ничего сложного уже нету.

[Antonariy]

А еще можно было бы воспользоваться MSHTML

Код: Выделить всё

Function TextFromHTML(StrHTML as String) as String
Dim d as New MSHTML.HTMLDocument
    d.documentElement.outerHTML = StrHTML
    TextFromHTML = d.documentElement.innerText
End Function

И все!