'запуск при открытии аутлука
Call HereWeHave
End Sub
Private Sub HereWeHave()
Dim s As String, v As Variant, i As Long, l As Long, s_path$
's_path2 = "C:\Users\fpotokin\AppData\Roaming\Microsoft\Signatures\" & "signature01.htm"
' Open s_path2 For Input As #1
' s2 = Input(LOF(1), 1)
' Close #1
's2 = Replace(s2, "signature01.htm", "CarcadeCorporateSignature.htm")
's2 = Replace(s2, "png", "jpg")
's2 = Replace(s2, "002", "001")
''
s_path = "C:\Users\fpotokin\AppData\Roaming\Microsoft\Signatures\" & "CarcadeCorporateSignature.htm"
Open s_path For Input As #1
s = Input(LOF(1), 1)
v = Split(s, vbCrLf)
Close #1
Open s_path For Output As #2
s = ""
' v(824) = s
v(781) = Replace(v(781), "<o:p> </o:p>", "")
' v(796) = Replace(v(796), "<br/>", "")
For i = 782 To 843
v(i) = s
Next i
s = Join(v, vbCrLf)
Print #2, s
' Print #2, Join(v, vbCrLf)
' For i = 0 To UBound(v) - l
' s = v(i)
' s = Replace(s, "#4 """, "#4 Hello")
' s = Replace(s, "#5 """, "#5 Hello")
' Print #2, s
' Next
Close #2
End Sub
Public Function ъСцепитьУникальныеЗначенияПоУсловию(условие As Range, столбец_условий As Range, столбец_значений As Range, Optional разделитель As String) As String
Dim s_ans$, i%, curfilename$
Dim Col_n As Collection
Set Col_n = New Collection
For Each cell In столбец_условий
i = i + 1
If cell = условие Then
curfilename = столбец_значений.Cells(i, 1).Value
On Error Resume Next
Col_n.Add curfilename, curfilename
If Err = 0 Then
s_ans = s_ans & разделитель & столбец_значений.Cells(i, 1).Value
Else
Err.Clear
End If
End If
Next
Set Col_n = Nothing
a = 15
ъСцепитьУникальныеЗначенияПоУсловию = Mid(s_ans, Len(разделитель) + 1)
End Function
| Sub ClearContent(sht_for_clearing As String) Dim curWB As Worksheet, s_lastcol$ Set curWB = ThisWorkbook.Worksheets(sht_for_clearing) s_lastcol = Split(ThisWorkbook.Worksheets(sht_for_clearing).UsedRange.Address, ":")(1) curWB.Range("A2:" & s_lastcol).ClearContents 'Подтираем за собой Set curWB = Nothing End Sub |