Чтение по координатам + несколько вопросов

[A.A.Z.]

2 -

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

Sub LoadForm()
Dim NewForm As New Form1 'Form1 - имя существующей формы
Set NewForm = New Form1
Load NewForm
NewForm.Visible=True
End Sub


[Amed]

1)
Вот так, примерно:

У тебя даны точки: A(x1;y1) и B(x2,y2)

Если известна координата X произвольной точки на линии AB, а координата Y неизвестна, то её мы находим из формулы

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

Lambda = (x - x1) / (x2 - x)
Y = (y1 + Lambda * y2) / (1 + Lambda)


Т.о., остаётся только сделать цикл от x1 до x2 с тем, чтобы найти y-координаты точек, принадлежащих линии AB. Затем по найденной точке C(x;y) ищем её цвет:

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

Dim pClr as Long
c=Me.Point(x,y)

Я думаю, дальше Вы сами разберётесь

Картинка

[Amed]

4)

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

'**************************************
' Name: LZW Compression for VB strings
' Description:Another implementation of
'     LZW compression for compressing VB strin
'     gs. A 4K dictionary is used as suggested
'     by the algorithm. A binary tree search i
'     s used for speeding up dictionary search
'     . It accepts all the 256 characters. ***
'     version 2 (23-Aug-99): bug fixed, perfor
'     mance improved ***
' By: lcwd
'
'This code is copyrighted and has' limited warranties.Please see http://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.asp?txtCodeId=2075&lngWId=1'for details.'**************************************

' Special thanks to Chris Dodge for repo
'     rting the bug
Option Explicit


Private Type BNode
    DictIdx As Long
    pLeft As Long
    pRight As Long
    End Type
    Dim Dict(4096) As String
    Dim NextDictIdx As Long
    Dim Heap(4096) As BNode
    Dim NextHeapIdx As Long
    Dim pStr As Long


Sub InitDict()
    Dim i As Integer
   


    For i = 0 To 255
        Dict(i) = Chr(i)
    Next i
    ' Not really necessary
    '
    ' For i = 256 To 4095
    ' Dict(i) = ""
    ' Next i
   
NextDictIdx = 256
NextHeapIdx = 0
End Sub


Function AddToDict(s As String) As Long
If NextDictIdx > 4095 Then
    NextDictIdx = 256
    NextHeapIdx = 0
End If

If Len(s) = 1 Then
    AddToDict = Asc(s)
Else
    AddToDict = AddToBTree(0, s)
End If
End Function


Function AddToBTree(ByRef Node As Long, ByRef s As String) As Long
    Dim i As Integer
   


    If Node = -1 Or NextHeapIdx = 0 Then
        Dict(NextDictIdx) = s
        Heap(NextHeapIdx).DictIdx = NextDictIdx
    NextDictIdx = NextDictIdx + 1
    Heap(NextHeapIdx).pLeft = -1
    Heap(NextHeapIdx).pRight = -1
    Node = NextHeapIdx
NextHeapIdx = NextHeapIdx + 1
AddToBTree = -1
Else
i = StrComp(s, Dict(Heap(Node).DictIdx))


If i < 0 Then
    AddToBTree = AddToBTree(Heap(Node).pLeft, s)
ElseIf i > 0 Then
    AddToBTree = AddToBTree(Heap(Node).pRight, s)
Else
    AddToBTree = Heap(Node).DictIdx
End If
End If
End Function


Private Sub WriteStrBuf(s As String, s2 As String)


    Do While pStr + Len(s2) - 1 > Len(s)
        s = s & Space(100000)
    Loop
    Mid$(s, pStr) = s2
    pStr = pStr + Len(s2)
End Sub


Function Compress(IPStr As String) As String
    Dim TmpStr As String
    Dim Ch As String
    Dim DictIdx As Integer
    Dim LastDictIdx As Integer
    Dim FirstInPair As Boolean
    Dim HalfCh As Integer
    Dim i As Long
    Dim ostr As String
   
    InitDict
    FirstInPair = True
    pStr = 1
   


    For i = 1 To Len(IPStr)
        Ch = Mid$(IPStr, i, 1)
       
        DictIdx = AddToDict(TmpStr & Ch)


        If DictIdx = -1 Then


            If FirstInPair Then
                HalfCh = (LastDictIdx And 15) * 16
            Else
                WriteStrBuf ostr, Chr(HalfCh Or (LastDictIdx And 15))
            End If
            WriteStrBuf ostr, Chr(LastDictIdx \ 16)
            FirstInPair = Not FirstInPair
            TmpStr = Ch
            LastDictIdx = Asc(Ch)
        Else
            TmpStr = TmpStr & Ch
            LastDictIdx = DictIdx
        End If
    Next i
   
    WriteStrBuf ostr, _
    IIf(FirstInPair, Chr(LastDictIdx \ 16) & Chr((LastDictIdx And 15) * 16), _
    Chr(HalfCh Or (LastDictIdx And 15)) & Chr(LastDictIdx \ 16))
   
    Compress = Left(ostr, pStr - 1)
   
End Function


Function GC(str As String, position As Long) As Integer
    GC = Asc(Mid$(str, position, 1))
End Function


Function DeCompress(IPStr As String) As String
    Dim DictIdx As Integer
    Dim FirstInPair As Boolean
    Dim i As Long
    Dim s As String
    Dim s2 As String
    InitDict
    pStr = 1
    i = 1
    FirstInPair = True
   


    Do While i < Len(IPStr)


        If FirstInPair Then
            DictIdx = (GC(IPStr, i) * 16) Or (GC(IPStr, i + 1) \ 16)
            i = i + 1
        Else
            DictIdx = (GC(IPStr, i + 1) * 16) Or (GC(IPStr, i) And 15)
            i = i + 2
        End If
        FirstInPair = Not FirstInPair
       


        If i > 2 Then


            If DictIdx = NextDictIdx Or (DictIdx = 256 And NextDictIdx = 4096) Then
                AddToDict s2 & Left$(s2, 1)
            Else
                AddToDict s2 & Left$(Dict(DictIdx), 1)
            End If
        End If
        s2 = Dict(DictIdx)
        WriteStrBuf s, s2
    Loop
   
    DeCompress = Left(s, pStr - 1)
End Function


Sub test()
    Dim s As String
   
    MousePointer = vbHourglass
   
    s = Compress(Text1)
    text2 = DeCompress(s)
    Text3 = Len(Text1)
    Text4 = Len(s)
   
    If Text1 <> text2 Then
        Text5 = "error"
    Else
        Text5 = "ok"
    End If
   
    MousePointer = vbNormal
End Sub

Вот примерчик сжатия алгоритмом LZW... Вроде, сжимает неплохо... Разберёшся, как пользоваться?

P.S. если что, поищи что-нибудь на http://www.planetsourcecode.com с запросом вроде "lzw" или "lzh"

[A.A.Z.]

http://www.vbstreets.ru/VB/Sources/Down ... x?id=42704
77 алгоритмов сжатия

[hCORe]

A.A.Z, к сожалению все алгоритмы из этих медленные и плохо сжимающие. 10 Мб за 15 минут на P4 2GHz - это тянет на шедевр . Впрочем, ничего другого и я не нашел. Хотел делать архиватор и бросил эту затею

ЗЫ. Двоичные файлы ими сжимать почти нельзя, а вот простенькие тексты - запросто, где-нибудь 75% отрежет

[A.A.Z.]

Ну, исходников WinRAR я еще не видел, поэтому что есть - то есть...