Автоматически менять интернет адрес на гиперссылку — Visual Basic(Бейсик)

disel
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Option Compare Text
  
Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'XL97
    Dim iSource As Range, iCell As Range
    Set iSource = Intersect(Target, [A2:A100])
    If Not iSource Is Nothing Then
       For Each iCell In iSource
           If iCell.Text Like "www.*" Then
              Hyperlinks.Add Anchor:=iCell, Address:="http://" & iCell
           ElseIf iCell.Text Like "http://*" Then
              Hyperlinks.Add Anchor:=iCell, Address:=iCell
           End If
       Next
    End If
End Sub
code: #vba
Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'XL97
    Dim iSource As Range, iCell As Range
    Set iSource = Intersect(Target, [A2:A100])
    If Not iSource Is Nothing Then
       For Each iCell In iSource
           If InStr(1, iCell, "www.", vbTextCompare) = 1 Then
              Hyperlinks.Add Anchor:=iCell, Address:="http://" & iCell
           ElseIf InStr(1, iCell, "http://", vbTextCompare) = 1 Then
              Hyperlinks.Add Anchor:=iCell, Address:=iCell
           End If
       Next
    End If
End Sub
code: #vba
Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'XL97
    Dim iSource As Range, iCell As Range, iText$
    Set iSource = Intersect(Target, [A2:A100])
    If Not iSource Is Nothing Then
       If Application.Sum(Application.CountIf( _
          iSource, Array("http://*", "www.*"))) = 0 Then
          'MsgBox "В этом диапазоне нет URL адресов", vbInformation, ""
          Exit Sub
       End If
       For Each iCell In iSource
           iText = LCase(CStr(iCell))
           Select Case True
               Case iText Like "www.*"
               Hyperlinks.Add Anchor:=iCell, Address:="http://" & iText
               Case iText Like "http://*"
               Hyperlinks.Add Anchor:=iCell, Address:=iText
           End Select
       Next
    End If
End Sub
Полная версия (включает также создание гиперссылок, типа info@samplecode.ru , mailto:admin@samplecode.ru)
 
code: #vba
Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'XL97
    Dim iSource As Range, iCell As Range, iAddress$
    Set iSource = Intersect(Target, Me.[A2:A100])
    If iSource Is Nothing Then Exit Sub
  
    iArrPrefix = Array("http://*", "ftp.*", "www.*", "mailto:*", "*@*.*")
    With Application
         If .Sum(.CountIf(Target, iArrPrefix)) = 0 Then Exit Sub
         '.ScreenUpdating = False
         For Each iCell In iSource
             iIndexPrefix = .Match(1, .CountIf(iCell, iArrPrefix), 0)
             If Not IsError(iIndexPrefix) Then
                iAddress = Choose(iIndexPrefix, "", _
                "ftp://", "http://", "", "mailto:") & iCell.Value
                Me.Hyperlinks.Add Anchor:=iCell, Address:=iAddress
             End If
         Next
         '.ScreenUpdating = True
    End With
End Sub

Похожие записи/страницы:

Leave a Comment