transperant form i visual basic 6

Hej syscom!

Webcrawler

Enjoy!

\' Sådan laver du en gennemsigtig baggrund på formen:
\' ------------------------------------------------

\' 1. del skal i et Class Modul ved navn cDIBSection
\' 2. del skal i et andet Class Modul ved navn cDIBSectionRegion
\' 3. del tilføjes i form1 sammen med kontrollen Picrture1
\' Picture1 er nu din dialogboks. Alt det sorte på det billed du
\' indsætter i Picture1 bliver gennemsigtigt, \' sammen med den evt.
\' øvrige dialogboks-baggrund. Du kan nu tilføje øvrige kontroller på
\' Picture1.


\'1. del:
Option Explicit
Private Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib \"msvbvm50.dll\" Alias \"VarPtr\" (Ptr() As Any) As Long

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER \'40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib \"gdi32\" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib \"USER32\" (ByVal hWnd As Long) As Long
Private Declare Function GetDesktopWindow Lib \"USER32\" () As Long
Private Declare Function CreateDIBSection Lib \"gdi32\" _
    (ByVal hdc As Long, _
    pBitmapInfo As BITMAPINFO, _
    ByVal un As Long, _
    lplpVoid As Long, _
    ByVal handle As Long, _
    ByVal dw As Long) As Long
Private Declare Function BitBlt Lib \"gdi32\" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib \"gdi32\" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib \"gdi32\" (ByVal hdc As Long) As Long
Private Declare Function LoadImage Lib \"USER32\" Alias \"LoadImageA\" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib \"gdi32\" Alias \"GetObjectA\" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function timeGetTime Lib \"winmm.dll\" () As Long
Private Declare Function CreateCompatibleBitmap Lib \"gdi32\" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function OpenClipboard Lib \"USER32\" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib \"USER32\" () As Long
Private Declare Function SetClipboardData Lib \"USER32\" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib \"USER32\" () As Long
Private Const CF_BITMAP = 2
Private Const CF_DIB = 8

Private m_hDIb As Long
Private m_hBmpOld As Long
Private m_hDC As Long
Private m_lPtr As Long
Private m_tBI As BITMAPINFO

Public Function CopyToClipboard( _
        Optional ByVal bAsDIB As Boolean = True _
    ) As Boolean
Dim lhDCDesktop As Long
Dim lhDC As Long
Dim lhBmpOld As Long
Dim hObj As Long
Dim lFmt As Long
Dim b() As Byte
Dim tBI As BITMAPINFO
Dim lPtr As Long
Dim hDibCopy As Long

    lhDCDesktop = GetDC(GetDesktopWindow())
    If (lhDCDesktop <> 0) Then
        lhDC = CreateCompatibleDC(lhDCDesktop)
        If (lhDC <> 0) Then
            If (bAsDIB) Then
              MsgBox \"I don\'t know how to put a DIB on the clipboard! Copy as bitmap instead!!!\"
            Else
                hObj = CreateCompatibleBitmap(lhDCDesktop, Width, Height)
                If (hObj <> 0) Then
                    lhBmpOld = SelectObject(lhDC, hObj)
                    PaintPicture lhDC
                    SelectObject lhDC, lhBmpOld
                    lFmt = CF_BITMAP
                    If (OpenClipboard(0) <> 0) Then
                        EmptyClipboard
                        If (SetClipboardData(lFmt, hObj) <> 0) Then
                            CopyToClipboard = True
                        End If
                        CloseClipboard
                    End If
                End If
            End If
            DeleteDC lhDC
        End If
        DeleteDC lhDCDesktop
    End If
End Function

Public Function CreateDIB( _
        ByVal lhDC As Long, _
        ByVal lWidth As Long, _
        ByVal lHeight As Long, _
        ByRef hDib As Long _
    ) As Boolean
    With m_tBI.bmiHeader
        .biSize = Len(m_tBI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    hDib = CreateDIBSection( _
            lhDC, _
            m_tBI, _
            DIB_RGB_COLORS, _
            m_lPtr, _
            0, 0)
    CreateDIB = (hDib <> 0)
End Function
Public Function CreateFromPicture( _
        ByRef picThis As StdPicture _
    )
Dim lhDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
Dim tBMP As BITMAP
   
    GetObjectAPI picThis.handle, Len(tBMP), tBMP
    If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
        lhDCDesktop = GetDC(GetDesktopWindow())
        If (lhDCDesktop <> 0) Then
            lhDC = CreateCompatibleDC(lhDCDesktop)
            DeleteDC lhDCDesktop
            If (lhDC <> 0) Then
                lhBmpOld = SelectObject(lhDC, picThis.handle)
                LoadPictureBlt lhDC
                SelectObject lhDC, lhBmpOld
                DeleteObject lhDC
            End If
        End If
    End If
End Function
Public Function Create( _
        ByVal lWidth As Long, _
        ByVal lHeight As Long _
    ) As Boolean
    ClearUp
    m_hDC = CreateCompatibleDC(0)
    If (m_hDC <> 0) Then
        If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
            m_hBmpOld = SelectObject(m_hDC, m_hDIb)
            Create = True
        Else
            DeleteObject m_hDC
            m_hDC = 0
        End If
    End If
End Function
Public Property Get BytesPerScanLine() As Long
    BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property

Public Property Get Width() As Long
    Width = m_tBI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
    Height = m_tBI.bmiHeader.biHeight
End Property

Public Sub LoadPictureBlt( _
        ByVal lhDC As Long, _
        Optional ByVal lSrcLeft As Long = 0, _
        Optional ByVal lSrcTop As Long = 0, _
        Optional ByVal lSrcWidth As Long = -1, _
        Optional ByVal lSrcHeight As Long = -1, _
        Optional ByVal eRop As RasterOpConstants = vbSrcCopy _
    )
    If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
    If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
    BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop
End Sub

Public Sub PaintPicture( _
        ByVal lhDC As Long, _
        Optional ByVal lDestLeft As Long = 0, _
        Optional ByVal lDestTop As Long = 0, _
        Optional ByVal lDestWidth As Long = -1, _
        Optional ByVal lDestHeight As Long = -1, _
        Optional ByVal lSrcLeft As Long = 0, _
        Optional ByVal lSrcTop As Long = 0, _
        Optional ByVal eRop As RasterOpConstants = vbSrcCopy _
    )
    If (lDestWidth < 0) Then lDestWidth = m_tBI.bmiHeader.biWidth
    If (lDestHeight < 0) Then lDestHeight = m_tBI.bmiHeader.biHeight
    BitBlt lhDC, lDestLeft, lDestTop, lDestWidth, lDestHeight, m_hDC, lSrcLeft, lSrcTop, eRop
End Sub

Public Property Get hdc() As Long
    hdc = m_hDC
End Property
Public Property Get hDib() As Long
    hDib = m_hDIb
End Property
Public Property Get DIBSectionBitsPtr() As Long
    DIBSectionBitsPtr = m_lPtr
End Property
Public Sub RandomiseBits( _
        Optional ByVal bGray As Boolean = False _
    )
Dim bDib() As Byte
Dim x As Long, y As Long
Dim lC As Long
Dim tSA As SAFEARRAY2D
Dim xEnd As Long
   
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerScanLine()
        .pvData = m_lPtr
    End With
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4

    Randomize timer
   
    xEnd = (Width - 1) * 3
    If (bGray) Then
        For y = 0 To m_tBI.bmiHeader.biHeight - 1
            For x = 0 To xEnd Step 3
                lC = Rnd * 255
                bDib(x, y) = lC
                bDib(x + 1, y) = lC
                bDib(x + 2, y) = lC
            Next x
        Next y
    Else
        For x = 0 To xEnd Step 3
            For y = 0 To m_tBI.bmiHeader.biHeight - 1
                bDib(x, y) = 0
                bDib(x + 1, y) = Rnd * 255
                bDib(x + 2, y) = Rnd * 255
            Next y
        Next x
    End If
   
  CopyMemory ByVal VarPtrArray(bDib), 0&, 4
   
End Sub

Public Sub ClearUp()
    If (m_hDC <> 0) Then
        If (m_hDIb <> 0) Then
            SelectObject m_hDC, m_hBmpOld
            DeleteObject m_hDIb
        End If
        DeleteObject m_hDC
    End If
    m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
End Sub

Public Function Resample( _
        ByVal lNewHeight As Long, _
        ByVal lNewWidth As Long _
    ) As cDIBSection
Dim cDib As cDIBSection
    Set cDib = New cDIBSection
    If cDib.Create(lNewWidth, lNewHeight) Then
        If (lNewWidth <> m_tBI.bmiHeader.biWidth) Or (lNewHeight <> m_tBI.bmiHeader.biHeight) Then
            ResampleDib cDib
        Else
            cDib.LoadPictureBlt m_hDC
        End If
        Set Resample = cDib
    End If
End Function

Private Function ResampleDib(ByRef cDibTo As cDIBSection) As Boolean
Dim bDibFrom() As Byte
Dim bDibTo() As Byte

Dim tSAFrom As SAFEARRAY2D
Dim tSATo As SAFEARRAY2D

    With tSAFrom
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerScanLine()
        .pvData = m_lPtr
    End With
    CopyMemory ByVal VarPtrArray(bDibFrom()), VarPtr(tSAFrom), 4

    With tSATo
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cDibTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cDibTo.BytesPerScanLine()
        .pvData = cDibTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bDibTo()), VarPtr(tSATo), 4

Dim xScale As Single
Dim yScale As Single

Dim x As Long, y As Long, xEnd As Long, xOut As Long

Dim fX As Single, fY As Single
Dim ifY As Long, ifX As Long
Dim dX As Single, dy As Single
Dim r As Long, r1 As Single, r2 As Single, r3 As Single, r4 As Single
Dim g As Long, g1 As Single, g2 As Single, g3 As Single, g4 As Single
Dim b As Long, b1 As Single, b2 As Single, b3 As Single, b4 As Single
Dim ir1 As Long, ig1 As Long, ib1 As Long
Dim ir2 As Long, ig2 As Long, ib2 As Long

    xScale = (Width - 1) / cDibTo.Width
    yScale = (Height - 1) / cDibTo.Height
   
    xEnd = cDibTo.Width - 1
       
    For y = 0 To cDibTo.Height - 1
       
        fY = y * yScale
        ifY = Int(fY)
        dy = fY - ifY
       
        For x = 0 To xEnd
            fX = x * xScale
            ifX = Int(fX)
            dX = fX - ifX
           
            ifX = ifX * 3
            b1 = bDibFrom(ifX, ifY): g1 = bDibFrom(ifX + 1, ifY): r1 = bDibFrom(ifX + 2, ifY)
            b2 = bDibFrom(ifX + 3, ifY): g2 = bDibFrom(ifX + 4, ifY): r2 = bDibFrom(ifX + 5, ifY)
            b3 = bDibFrom(ifX, ifY + 1): g3 = bDibFrom(ifX + 1, ifY + 1): r3 = bDibFrom(ifX + 2, ifY + 1)
            b4 = bDibFrom(ifX + 3, ifY + 1): g4 = bDibFrom(ifX + 4, ifY + 1): r4 = bDibFrom(ifX + 5, ifY + 1)
           
            ir1 = r1 * (1 - dy) + r3 * dy: ig1 = g1 * (1 - dy) + g3 * dy: ib1 = b1 * (1 - dy) + b3 * dy
            ir2 = r2 * (1 - dy) + r4 * dy: ig2 = g2 * (1 - dy) + g4 * dy: ib2 = b2 * (1 - dy) + b4 * dy
            r = ir1 * (1 - dX) + ir2 * dX: g = ig1 * (1 - dX) + ig2 * dX: b = ib1 * (1 - dX) + ib2 * dX
           
            If (r < 0) Then r = 0
            If (r > 255) Then r = 255
            If (g < 0) Then g = 0
            If (g > 255) Then g = 255
            If (b < 0) Then b = 0
            If (b > 255) Then
                b = 255
            End If
            xOut = x * 3
            bDibTo(xOut, y) = b
            bDibTo(xOut + 1, y) = g
            bDibTo(xOut + 2, y) = r
           
        Next x
       
    Next y
    CopyMemory ByVal VarPtrArray(bDibFrom), 0&, 4
    CopyMemory ByVal VarPtrArray(bDibTo), 0&, 4
End Function

Private Sub Class_Terminate()
    ClearUp
End Sub


\'2. del:
Option Explicit
Private Declare Function CreateRectRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib \"gdi32\" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_AND = 1
Private Const RGN_COPY = 5
Private Const RGN_DIFF = 4
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib \"USER32\" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function GetRegionData Lib \"gdi32\" (ByVal hRgn As Long, ByVal dwCount As Long, lpRgnData As Any) As Long
Private Declare Function ExtCreateRegion Lib \"gdi32\" (lpXform As Any, ByVal nCount As Long, lpRgnData As Any) As Long
Private Declare Function LoadLibraryEx Lib \"kernel32\" Alias \"LoadLibraryExA\" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function FreeLibrary Lib \"kernel32\" (ByVal hLibModule As Long) As Long
Private Declare Function LoadResource Lib \"kernel32\" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function LockResource Lib \"kernel32\" (ByVal hResData As Long) As Long
Private Declare Function FindResource Lib \"kernel32\" Alias \"FindResourceA\" (ByVal hInstance As Long, lpName As Any, lpType As Any) As Long
Private Declare Function SizeofResource Lib \"kernel32\" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function FreeResource Lib \"kernel32\" (ByVal hResData As Long) As Long
Private Const LOAD_LIBRARY_AS_DATAFILE = &H2&
Private Const RT_RCDATA = 10&

Private Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib \"msvbvm50.dll\" Alias \"VarPtr\" (Ptr() As Any) As Long

Private m_hRgn As Long
Private m_hWnd() As Long
Private m_iCount As Long

Public Property Get Applied(ByVal hWnd As Long) As Boolean
  Applied = Not (plIndex(hWnd) = 0)
End Property
Public Property Let Applied(ByVal hWnd As Long, ByVal bState As Boolean)
Dim i As Long
Dim lIndex As Long
  lIndex = plIndex(hWnd)
  If bState Then
      If (lIndex = 0) Then
        m_iCount = m_iCount + 1
        ReDim Preserve m_hWnd(1 To m_iCount) As Long
        m_hWnd(m_iCount) = hWnd
        SetWindowRgn m_hWnd(m_iCount), m_hRgn, True
      Else
        SetWindowRgn m_hWnd(m_iCount), m_hRgn, True
      End If
  Else
      If (lIndex = 0) Then
        SetWindowRgn hWnd, 0, True
      Else
        SetWindowRgn hWnd, 0, True
        If m_iCount > 1 Then
            For i = lIndex To m_iCount - 1
              m_hWnd(i) = m_hWnd(i + 1)
            Next i
            m_iCount = m_iCount - 1
            ReDim Preserve m_hWnd(1 To m_iCount) As Long
        Else
            m_iCount = 0
            Erase m_hWnd
        End If
      End If
  End If
End Property
Private Property Get plIndex(ByVal hWnd As Long) As Long
Dim i As Long
Dim lIndex As Long
  For i = 1 To m_iCount
      If hWnd = m_hWnd(i) Then
        plIndex = i
        Exit For
      End If
  Next i
End Property
Public Property Get AppliedToCount() As Long
  AppliedToCount = m_iCount
End Property
Public Property Get hWndForIndex(ByVal lIndex As Long) As Long
  hWndForIndex = m_hWnd(lIndex)
End Property

Private Sub UnApply()
Dim i As Long
  For i = 1 To m_iCount
      If Not m_hWnd(i) = 0 Then
        SetWindowRgn m_hWnd(i), 0, True
        m_hWnd(i) = 0
      End If
  Next i
  m_iCount = 0
End Sub
Public Sub Destroy()
  UnApply
  If Not m_hRgn = 0 Then
      DeleteObject m_hRgn
  End If
  m_hRgn = 0
End Sub

Public Sub Create( _
      ByRef cDib As cDIBSection, _
      Optional ByRef lTransColor As Long = 0 _
  )
Dim x As Long, y As Long
Dim lX As Long
Dim yStart As Long
Dim bStart As Boolean
Dim hRgnTemp As Long
Dim bR As Byte, bG As Byte, bB As Byte
Dim lWidth As Long, lHeight As Long
Dim bDib() As Byte
Dim tSA As SAFEARRAY2D

  Destroy
  bR = (lTransColor And &HFF&)
  bG = (lTransColor And &HFF00&) \\ &H100&
  bB = (lTransColor And &HFF0000) \\ &H10000
 
  m_hRgn = CreateRectRgn(0, 0, cDib.Width, cDib.Height)
  Debug.Assert (m_hRgn <> 0)
  If m_hRgn <> 0 Then
      With tSA
          .cbElements = 1
          .cDims = 2
          .Bounds(0).lLbound = 0
          .Bounds(0).cElements = cDib.Height
          .Bounds(1).lLbound = 0
          .Bounds(1).cElements = cDib.BytesPerScanLine()
          .pvData = cDib.DIBSectionBitsPtr
      End With
      CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
             
      lWidth = cDib.BytesPerScanLine \\ 3
      lHeight = cDib.Height
      For x = 0 To (lWidth - 1) * 3 Step 3
        For y = lHeight - 1 To 0 Step -1
            If bDib(x, y) = bB And bDib(x + 1, y) = bG And bDib(x + 2, y) = bR Then
              If Not bStart Then
                  yStart = lHeight - 1 - y
                  bStart = True
              End If
            Else
              If bStart Then
                  hRgnTemp = CreateRectRgn(lX, yStart, lX + 1, lHeight - 1 - y)
                  CombineRgn m_hRgn, hRgnTemp, m_hRgn, RGN_XOR
                  DeleteObject hRgnTemp
                  bStart = False
              End If
            End If
        Next y
        If bStart Then
            hRgnTemp = CreateRectRgn(lX, yStart, lX + 1, lHeight - 1 - y)
            CombineRgn m_hRgn, hRgnTemp, m_hRgn, RGN_XOR
            DeleteObject hRgnTemp
            bStart = False
        End If
        lX = lX + 1
      Next x
     
      CopyMemory ByVal VarPtrArray(bDib), 0&, 4
     
  End If
End Sub

Public Function Save(ByVal sPath As String) As Boolean
Dim iFile As Long
Dim nBytes As Long
Dim b() As Byte

On Error GoTo ErrorHandler

  If Not m_hRgn = 0 Then
     
      nBytes = GetRegionData(m_hRgn, 0, ByVal 0&)
      If nBytes > 0 Then
        ReDim b(0 To nBytes - 1) As Byte
        If nBytes = GetRegionData(m_hRgn, nBytes, b(0)) Then
            On Error Resume Next
            Kill sPath
            On Error GoTo ErrorHandler
            iFile = FreeFile
            Open sPath For Binary Access Write Lock Read As #iFile
            Put #iFile, , b
            Close #iFile
            Save = True
        Else
            Err.Raise 26012, App.EXEName & \".cDIBSectionRegion\", \"Unable to get region data\"
        End If
      Else
        Err.Raise 26011, App.EXEName & \".cDIBSectionRegion\", \"Unable to determine size of region\"
      End If
  Else
      Err.Raise 26010, App.EXEName & \".cDIBSectionRegion\", \"No region to save\"
  End If
  Exit Function
 
ErrorHandler:
Dim lErr As Long, sErr As String
  lErr = Err.Number: sErr = Err.Description
  If iFile > 0 Then
      Close #iFile
  End If
  Err.Raise lErr, App.EXEName & \".cDIBSectionRegion\", sErr
  Exit Function
End Function

Public Function LoadFromFile(ByVal sFileName As String) As Boolean
Dim iFile As Long
Dim b() As Byte
On Error GoTo ErrorHandler

  iFile = FreeFile
  Open sFileName For Binary Access Read Lock Write As #iFile
  ReDim b(0 To LOF(iFile) - 1) As Byte
  Get #iFile, , b
  Close #iFile

  LoadFromFile = pbLoadFromByteArray(b())
  Exit Function

ErrorHandler:
Dim lErr As Long, sErr As String
  lErr = Err.Number: sErr = Err.Description
  If iFile > 0 Then
      Close #iFile
  End If
  Err.Raise lErr, App.EXEName & \".cDIBSectionRegion\", sErr
  Exit Function
End Function

Public Function LoadFromResource(ByVal vID As Variant, Optional ByVal sDLL As String = \"\") As Boolean
Dim b() As Byte


  If sDLL = \"\" Then
      b = LoadResData(vID, 10)
      LoadFromResource = pbLoadFromByteArray(b())
  Else
      Dim hMod As Long, hRes As Long, hGlobal As Long, lPtr As Long, lSize As Long
      Dim lID As Long, sID As String, lR As Long
     
      hMod = LoadLibraryEx(sDLL, ByVal 0&, LOAD_LIBRARY_AS_DATAFILE)
      If Not hMod = 0 Then
        If IsNumeric(vID) Then
            sID = \"#\" & CStr(vID)
        End If
        hRes = FindResource(hMod, ByVal sID, ByVal RT_RCDATA)
        If Not hRes = 0 Then
            lSize = SizeofResource(hMod, hRes)
            hGlobal = LoadResource(hMod, hRes)
            If Not hGlobal = 0 Then
              lPtr = LockResource(hGlobal)
              If Not lPtr = 0 Then
                  ReDim b(0 To lSize - 1) As Byte
                  CopyMemory b(0), ByVal lPtr, lSize
                  LoadFromResource = pbLoadFromByteArray(b())
              End If
            Else
              Err.Raise 26014, App.EXEName & \".cDIBSectionRegion\", \"Cannot access data for resource with ID \" & vID & \" could not be found\"
            End If
        Else
            Err.Raise 26014, App.EXEName & \".cDIBSectionRegion\", \"Resource with ID \" & vID & \" could not be found\"
        End If
        lR = FreeLibrary(hMod)
        Debug.Assert Not (lR = 0)
        If Not lR = 0 Then
            hMod = 0
        End If
      Else
        Err.Raise 26013, App.EXEName & \".cDIBSectionRegion\", \"Can\'t open DLL for Resource Access\"
      End If
  End If
  Exit Function

ErrorHandler:
Dim lErr As Long, sErr As String
  lErr = Err.Number: sErr = Err.Description
  If Not hMod = 0 Then
      lR = FreeLibrary(hMod)
      Debug.Assert Not (lR = 0)
  End If
  Err.Raise lErr, App.EXEName & \".cDIBSectionRegion\", sErr
  Exit Function
End Function

Private Function pbLoadFromByteArray(ByRef b() As Byte) As Boolean
Dim dwCount As Long
 
  Destroy
  dwCount = UBound(b) - LBound(b) + 1
  m_hRgn = ExtCreateRegion(ByVal 0&, dwCount, b(0))
  pbLoadFromByteArray = Not (m_hRgn = 0)
 
End Function

Private Sub Class_Terminate()
  Destroy
End Sub


\'3. del:
Option Explicit

Private Const WM_SYSCOMMAND = &H112&
Private Const SC_MOVE = &HF010&
Private m_cDibR As New cDIBSectionRegion

Private Sub Form_Load()
Dim cDib As New cDIBSection
  cDib.CreateFromPicture Picture1.Picture
  m_cDibR.Create cDib
  m_cDibR.Applied(Me.hWnd) = True
  Set Me.Picture = Picture1.Picture
End Sub

- det er godt nok ved hjælp af en billed-kontrol... - der var jeg lige lidt for hurtig.

-Webcrawler

kæft en smøre...Jeg mener jeg har noget som du måske kan bruge, jeg prøver lige at se om jeg kan finde det

Du kan måske bruge dette:

Dim FW As Long \' form width (in pixels)
Dim FH As Long \' form height (in pixels)
Dim FillMode As Long


Private Sub Command1_Click()
   
    Dim hRgn As Long
    Dim RetVal As Long
   
    Dim Points(8) As POINTAPI

    Points(0).x = 200
    Points(0).y = 0

    Points(1).x = 600
    Points(1).y = 0

    Points(2).x = 600
    Points(2).y = 50
     
    Points(3).x = 300
    Points(3).y = 50
   
    Points(4).x = 275
    Points(4).y = 100
   
    Points(5).x = 250
    Points(5).y = 100
   
    Points(6).x = 275
    Points(6).y = 50
   
    Points(7).x = 200
    Points(7).y = 50
       
    hRgn = CreatePolygonRgn(Points(0), 8, FillMode)

    Call SetWindowRgn(Form1.hWnd, hRgn, True)
   
End Sub

Med det kan du shape winduet som du vil (punkt for punkt) dog skal du også bruge et modul med følgende:

Public Declare Function SetWindowRgn Lib \"user32\" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreatePolygonRgn Lib \"gdi32\" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Declare Function CreatePolyPolygonRgn Lib \"gdi32\" (lpPoint As POINTAPI, lpPolyCounts As Long, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Declare Function GetPolyFillMode Lib \"gdi32\" (ByVal hdc As Long) As Long
Public Declare Function CreateEllipticRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CreateRoundRectRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Public Declare Function CombineRgn Lib \"gdi32\" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)
Public Declare Function CreateRectRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Public Type POINTAPI
        x As Long
        y As Long
End Type

Public Const RGN_AND = 1
Public Const RGN_COPY = 5
Public Const RGN_DIFF = 4
Public Const RGN_OR = 2
Public Const RGN_XOR = 3

Dim Points(8) As POINTAPI
hRgn = CreatePolygonRgn(Points(0), 8, FillMode)

Ved disse skal du lige ændre 8 tallet til at være det antal punkter du ønsker at bruge

hvor skal
Dim Points(8) As POINTAPI
hRgn = CreatePolygonRgn(Points(0), 8, FillMode)
placeres henne?

ah, har nevermind. læste ikke lige hvad der stod :) hehe

- dog kan jeg ikke lige få det til at virke....

hvis du selv ligger inde med filerne, og har fået det til at virke, kan du eventuelt sende dem til plj@3rdpixel.com

Dem sender jeg lige om lidt så!!!

ok, kanon :)

The file is in the mail...håber du har winrar, ellers siger du bare til og jeg sender en zip istedet...kom jeg først i tanke om da filen var sendt

det har jeg, venter spændt... :)

Har du ikke fået det endnu...hmmm, det elektroniske postvæsen tager sig nok godt med tid om søndagen

hehe - det kan der være noget om, men nope - det har jeg ikke.

Vis du har ICQ kan jeg sende det igennem der

det har jeg, men jeg tror ikke min router er så glad for det.

UIN: 113923220

jeg foretrækker desuden messenger :)

Er der andre med Win2K der heller ikke kan få denne kode til at virke eller er det bare syscoms maskine der ikke lige kan finde ud af det?