Le portail francophone de la géomatique

Public Sub MakeExtraction(h As RealRegion)
Dim r As GFL_RECT
Dim dummy&

'calcul l'intersection de l'image avec le rectangle
dummy& = GetzoneDIB(mdc, h)

With mRectbitmap
r.X = .Left
r.Y = mDIBinfo.bmiHeader.biHeight - (.Top + .Bottom)
r.w = .Right
r.h = .Bottom
End With

'utilisation de la dll LibGFL dispo à www.xnview.com

gflLibraryInit

dummy& = gflCrop(mGflBitmap, ByVal 0, r)

If dummy& = 0 Then

    mDIBinfo = extGetDIBFromBitmap(mGflBitmap)

    mAncreX = h.Left
    mAncreY = h.Bottom
    SetEspaceBitmap
    

End If

gflLibraryExit

End Sub


Public Function ExtractFromPolyline(PL As PolyLigne) As Long
Dim HmemTemp&
Dim Tmpaddr&
Dim dest&
Dim org&
Dim lign&
Dim TabInter() As Interval
Dim dy As Double
Dim Yvalue As Double
Dim dummy&
Dim l&
Dim f&
Dim i&
Dim j&
Dim count&
Dim h As RealRegion
Dim TabPoint() As Geopoint


'defini le rectangle mini/polyline et fais l'extraction


Set h = New RealRegion
Set PL = PL.IntersecWithRec(mEspacebitmap, True)
Set h = PL.Encadrante(True)
h.Dessine mdc
MakeExtraction h
' l'image est réduite au rectangle englobant la polyligne

'initialise tabpoint

ReDim TabPoint(PL.Sommets.count - 1)

For i& = 0 To PL.Sommets.count - 1
Set TabPoint(i&) = New Geopoint

TabPoint(i&).X = PL.Sommets(Trim$(Str(i + 1&))).X
TabPoint(i&).Y = PL.Sommets(Trim$(Str(i + 1&))).Y

Next i&

i& = 0
'reserve une zone tampon de la taille du bitmap et la rempli en blanc
HmemTemp& = GlobalAlloc(GMEM_MOVEABLE, mDIBinfo.bmiHeader.biSizeImage)
Tmpaddr& = GlobalLock(HmemTemp&)
Call FillMemory(Tmpaddr&, mDIBinfo.bmiHeader.biSizeImage, 255)
dummy& = GlobalUnlock(HmemTemp&)

'défini le pas réel
If mEstGeoref Then
dy = mTfwY
Else
dy = 1 / mDIBinfo.bmiHeader.biYPelsPerMeter * mEchelle
End If
Yvalue = mEspacebitmap.Bottom

For i& = 0 To mDIBinfo.bmiHeader.biHeight

TabInter = IntersectionYPolyline(TabPoint, Yvalue)

'si il existe un interval
On Error Resume Next
Err.Clear
count& = UBound(TabInter)
If Err.Number = 9 Then
'ne touche à rien
Else
'calcul l'adresse de la ligne en cours
lign& = i& * byteperscanline(mDIBinfo.bmiHeader.biWidth, mDIBinfo.bmiHeader.biBitCount)

For j& = 0 To count&

If TabInter(j&).start < h.Left Then
TabInter(j&).start = h.Left
End If
If TabInter(j&).end > h.Right Then
TabInter(j&).end = h.Right
End If

mdc.pointreal TabInter(j&).start, Yvalue, RGB(255, 0, 0)
mdc.pointreal TabInter(j&).end, Yvalue, RGB(0, 255, 0)
'calcul l'adresse de départ
l& = CLng((TabInter(j&).start - mEspacebitmap.Left) * mDIBinfo.bmiHeader.biXPelsPerMeter / mEchelle)

Select Case mDIBinfo.bmiHeader.biBitCount

Case 1
l& = l& \ 8

Case 8

Case 24
l& = l& * 3
Case 32
l& = l& * 4
End Select
l& = lign& + l&
' calcul l'adresse de fin
f& = CLng((TabInter(j&).end - TabInter(j&).start) * mDIBinfo.bmiHeader.biXPelsPerMeter / mEchelle)

Select Case mDIBinfo.bmiHeader.biBitCount
Case 1
f& = f& \ 8 + 1
Case 8
f& = f& + 1

Case 24
f& = f& * 3 + 3
Case 32
f& = f& * 4 + 4
End Select

'copie l'interval dans le bitmap temporaire
org& = GlobalLock(mGflBitmap.Data)
dest& = GlobalLock(HmemTemp&)
org& = org& + l&
dest& = dest& + l&
Call CopyMemory(dest&, org&, f&)
dummy& = GlobalUnlock(mGflBitmap.Data)
dummy& = GlobalUnlock(HmemTemp&)

Next j&

End If

Erase TabInter
Yvalue = Yvalue + dy

Next i&


dest& = GlobalLock(mGflBitmap.Data)
org& = GlobalLock(HmemTemp&)

Call CopyMemory(dest&, org&, mDIBinfo.bmiHeader.biSizeImage)
dummy& = GlobalUnlock(mGflBitmap.Data)
dummy& = GlobalUnlock(HmemTemp&)

GlobalFree (HmemTemp&)

For i& = 0 To PL.Sommets.count
Set TabPoint(i&) = Nothing

Next i&
Erase TabPoint
End Function

Private Function IntersectionYPolyline(TabGeoPoint() As Geopoint, Yvalue As Double) As Interval()
Dim count&
Dim i&
Dim j&
Dim Index&
Dim a As Double
Dim b As Double
Dim tabres() As Interval
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ptmp() As POINTGEO



On Error Resume Next

count& = UBound(TabGeoPoint)
If count& = 0 Or count& = -1 Then
Call MsgBox("La polyligne contient 0 ou 1 element !!", vbExclamation, "Calcul Vectoriel")
On Error GoTo 0
Exit Function
Else

    On Error GoTo 0
    
    For i& = 0 To count&
    
    If i& = count& Then
    
    If TabGeoPoint(i&).Y < TabGeoPoint(0).Y Then
        p1.X = TabGeoPoint(i&).X
        p1.Y = TabGeoPoint(i&).Y
        p2.X = TabGeoPoint(0).X
        p2.Y = TabGeoPoint(0).Y
            
        Else
        p2.X = TabGeoPoint(i&).X
        p2.Y = TabGeoPoint(i&).Y
        p1.X = TabGeoPoint(0).X
        p1.Y = TabGeoPoint(0).Y
       End If
    
    Else
        
       If TabGeoPoint(i&).Y < TabGeoPoint(i& + 1).Y Then
        p1.X = TabGeoPoint(i&).X
        p1.Y = TabGeoPoint(i&).Y
        p2.X = TabGeoPoint(i& + 1).X
        p2.Y = TabGeoPoint(i& + 1).Y
    
        Else
        p2.X = TabGeoPoint(i&).X
        p2.Y = TabGeoPoint(i&).Y
        p1.X = TabGeoPoint(i& + 1).X
        p1.Y = TabGeoPoint(i& + 1).Y
       End If
    End If
    
    
    If p1.Y <= Yvalue And Yvalue <= p2.Y Then
    
        a = p2.X - p1.X
        
        On Error Resume Next
        Err.Clear
        Index& = UBound(ptmp)
        
        If Err.Number = 9 Then Index& = -1
        
        ReDim Preserve ptmp(Index& + 1)
        On Error GoTo 0
        
        If a = 0 Then
        ptmp(Index& + 1).X = p1.X
        ptmp(Index& + 1).Y = Yvalue
        Else
        a = (p2.Y - p1.Y) / a
        b = p1.Y - a * p1.X
        If a <> 0 Then
        ptmp(Index& + 1).X = (Yvalue - b) / a
        ptmp(Index& + 1).Y = Yvalue
        Else
        ptmp(Index& + 1).X = p2.X
        ptmp(Index& + 1).Y = Yvalue
        End If
        
        End If
        
        If p1.Y = Yvalue Or p2.Y = Yvalue Then ptmp(Index& + 1).Y = -1
    End If
        
    Next i&
    

'trie le tableau par x croissant
On Error Resume Next
Err.Clear
Index& = UBound(ptmp)

If Err.Number = 9 Then
On Error GoTo 0
Exit Function
End If

For i& = 0 To Index&
'p1.X = ptmp(i&).X
'p1.Y = ptmp(i&).Y

    For j& = i& + 1 To Index&
    'si plus petit swap
    If ptmp(j&).X < ptmp(i&).X Then
    p2.X = ptmp(i&).X
    p2.Y = ptmp(i&).Y
    ptmp(i&).X = ptmp(j&).X
    ptmp(i&).Y = ptmp(j&).Y
    ptmp(j&).X = p2.X
    ptmp(j&).Y = p2.Y

    End If
    Next j&
Next i&

count& = 0
Index& = 0

Do While Index& < UBound(ptmp) + 1
ReDim Preserve tabres(count&)

If ptmp(Index&).Y <> Yvalue Then
tabres(count&).start = ptmp(Index&).X
tabres(count&).end = ptmp(Index&).X
count& = count& + 1
Index = Index& + 1
Else
    If tabres(count&).start = 0 Then
    tabres(count&).start = ptmp(Index&).X
    Index& = Index& + 1
    Else
    tabres(count&).end = ptmp(Index&).X
    Index& = Index& + 1
    count& = count& + 1
    End If
End If

Loop
IntersectionYPolyline = tabres

End If
End Function