Function GET_Internet(Myurl, status)
On Error Resume Next
If Myurl = "В ячейке нет гиперссылки!" Then
GET_Internet = False
Exit Function
End If

Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
  timeout& = 5        ' в секундах
xmlhttp.Open "GET", Myurl, False
xmlhttp.Send
If xmlhttp.status = 200 Then
     If status = 1 Then GET_Internet = xmlhttp.responsetext Else GET_Internet = True
  Exit Function
  End If
  On Error GoTo 0
  GET_Internet = False
End Function

 Type POINTAPI
  x As Long
  y As Long
End Type

Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any)
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As Long



Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As LongPtr
Public Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Private Const MOUSEEVENTF_LEFTDOWN = &H2  'Íàæàòü ëåâóþ êíîïêó
Private Const MOUSEEVENTF_LEFTUP = &H4  'Îòïóñòèòü ëåâóþ êíîïêó
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)

Sub RGB_TEST()

Dim cpos As POINTAPI
Dim obj As Object, NewValue As String

GetCursorPos cpos
screendc = CreateDC("DISPLAY", "", "", 0&)
xm = cpos.x
ym = cpos.y
    lColor = GetPixel(screendc, xm, ym)

            Red = (lColor Mod 256)
            Green = (lColor \ 256) Mod 256
            Blue = (lColor \ 65536) Mod 256

mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, x, y, 0, 0

' вот тут макрос перестает быть адекватным!! происходит рассинхрон

[a1].select ' 
выделенная картинка или ячейка мышкой не хочет выделяться
End Sub

Private Sub UserForm_initialize()
CBpost.List = apost()
End Sub

Public apost()

sub www()

for i=...
....
 Dim apost()
 ReDim Preserve apost(k)
        Set arr(k) = art
        apost(k) = furnbook.Worksheets("бла_бла").Cells(art.Row, rgc.Column)  
        k = k + 1

...
next i
 end sub

Sub координаты_пересечения()
coord = координаты_проекции_точки(-6, 10, 4, -5, -12, 7)
End Sub

Function координаты_проекции_точки(x, y, x1, x2, y1, y2)
'''''''''''''классическая прямая вида  a*x+b*y+c=0
'a = y1 - y2
'b = x2 - x1
'c = x1 * y2 - x2 * y1
'''''''''''''''''''''''''''' -b*x-a*y+d=0 'перпендикулярная функция
...
координаты_проекции_точки = xp & yp
End Function

For i = LBound(f) To UBound(f)
    For j = 1 To rr
        x = InStr(x + 1, f(i), "/")
        
    Next j
    If x <> 0 Then
    f(i) = Mid(f(i), 1, x - 1)
    End If
    x = 0
    
    If k = f(i) Then
    n = n + 1
    ReDim Preserve arr(n)
    arr(n) = tb.Cells(i, 13 + rr)

    End If
Next i

Sub Copy_Module()
    Dim objVBProjFrom As Object, objVBProjTo As Object, objVBComp As Object
    Dim sModuleName As String, sFullName As String
    'расширение стандартного модуля
    Const sExt As String = ".bas"
 
    'имя модуля для копирования
    sModuleName = "prefkpChan"
    On Error Resume Next
    'проект книги, из которой копируем модуль
    Set objVBProjFrom = ThisWorkbook.VBProject
    'необходимый компонент
    Set objVBComp = objVBProjFrom.VBComponents(sModuleName)
    'если указанного модуля не существует
    If objVBComp Is Nothing Then
        MsgBox "Модуль с именем '" & sModuleName & "' отсутствует в книге.", vbCritical, "Error"
        Exit Sub
    End If
    'проект книги для добавления модуля
    Set objVBProjTo = ActiveWorkbook.VBProject
    'полный путь для экспорта/импорта модуля. К папке должен быть доступ на запись/чтение
    sFullName = "C:\" & sModuleName & sExt
    objVBComp.Export Filename:=sFullName
    objVBProjTo.VBComponents.Import Filename:=sFullName
    'удаляем временный файл для импорта
    Kill sFullName
End Sub

 'проект книги, из которой копируем модуль
    Set objVBProjFrom = ThisWorkbook.VBProject

Sub test()
    For Each p In Sheets("Лист1").Shapes
          nnn = ActiveSheet.Shapes.Range(p.Name).ZOrderPosition
          nn = p.ZOrderPosition 'почему номера не совпадают?
    
    If nnn <> nn Then
    Debug.Print p.Name
    End If
    Next p
End Sub

Sub линии()
ActiveSheet.Shapes.Range("линия2").Width = 100
End Sub

for i=1 to rg.rows.count
if .....
n=n+1
ReDim Preserve ax(n, 20)
'тут хочется без цикла что то похожее на
[I]?диапазон[/I] ?( arr(n,1) ,arr(n,20)) = range rg(cells(i,1),cells(i,20)

Sub Макрос1()
 ActiveSheet.Shapes.Range(Array("картинка")).Fill.UserPicture Cells(1, 1)
End Sub

Function zapoln(table As Range, num_st As Integer, num_vhoda As Range, usmin As Integer, usmax As Integer)
Application.Volatile
Dim ax()
   
Set arr = table

Min = usmin
Max = usmax
s = num_st
With table.Parent
   h = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
 'количество элементов массива

For i = 1 To h
    If arr(i, s) > Min And arr(i, s) < Max Then
         n = n + 1
        ReDim Preserve ax(n)  ' Preserve переопределение с сохр всех значений
        ax(n) = arr(i, 1)
    End If
Next i
arr = ax

isk = num_vhoda.Row
On Error GoTo Err_SomeName
   zapoln = arr(isk)
Exit_SomeName:
     Exit Function
Err_SomeName:
    zapoln = 0
Resume Exit_SomeName

End Function

Sub Макрос()
Set r = Range("LOG")
f = r.Columns.Count
Sheets("формы").ListObjects("LOG").Resize Range(r.Cells(0, 1), r.Cells(1, f))
End Sub