Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Rotate bitmap

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Rotate bitmap

    I want to add rotate-procedure to view scanned documents.
    I found MSDN code and took main idea.
    Below you can see my initial attempt (tested under Win2000 only).

    Before test don't forget to change parameters in "Change this ..." section.


    Code:
       #Compile Exe
       #Register None
       #Dim All
       #Include "Win32Api.Inc"
    
       ' --- Change this ----
       $FileBmp1 = "C:\Background1.Bmp"
       $FileBmp2 = "C:\banner5.Bmp"
       %SizeX2 = 60 ' Size of rotated bitmap,
       %SizeY2 = 60 ' % to background
       %CenterX2 = 55 ' Location of center of rotated bitmap,
       %CenterY2 = 65 ' % to background
      
       %Speed = 20 ' Interval in ms between rotates
       %Angle = 10 ' Each step
       %RotateTransp = 1 ' Transparent
       '---------------------------------
    
       Function hBmpDIB32 (hBmp As Long) As Long
    
          Dim hdc As Long, hMemDC1 As Long, hMemDC2 As Long, hMemBmp As Long, hBmpOld As Long
          Dim bm As BITMAP, bmi As BITMAPINFO
    
          hDc = GetWindowDC(GetDesktopWindow)
          hMemDC1 = CreateCompatibleDC (hdc)
          hMemDC2 = CreateCompatibleDC (hMemDC1)
          ReleaseDC Getdesktopwindow, hDC
    
          SelectObject hMemDC1, hBmp
          GetObject hBmp, SizeOf (bm), bm
          bmi.bmiHeader.biSize = SizeOf(bmi.bmiHeader)
          bmi.bmiHeader.biWidth = bm.bmWidth
          bmi.bmiHeader.biHeight = bm.bmHeight
          bmi.bmiHeader.biPlanes = 1
          bmi.bmiHeader.biBitCount = 32
          bmi.bmiHeader.biCompression = %BI_RGB
          hMemBmp = CreateDIBSection(hMemDC2, bmi, %DIB_RGB_COLORS, 0, 0, 0)
          GlobalLock hMemBmp
          hBmpOld = SelectObject (hMemDC2, hMemBmp)
          BitBlt hMemDC2, 0, 0, bm.bmWidth, bm.bmHeight, hMemDC1, 0, 0, %SRCCOPY
          SelectObject hMemDC2, hBmpOld
          DeleteDC hMemDC1
          DeleteDC hMemDC2
          DeleteObject hBmp
          
          Dim i As Long, j As Long
          GetObject hMemBmp, SizeOf (bm), bm
          GetObject hBmp, SizeOf (bm), bm
          Dim ClrB() As Byte: ReDim ClrB(0 To 3, bm.bmWidth - 1, bm.bmHeight - 1) At bm.bmBits
          For i = 0 To bm.bmWidth - 1: For j = 0 To bm.bmHeight - 1: _
             ClrB(3, i, j) = %PC_EXPLICIT: Next: Next
             
          Function = hMemBmp
    
       End Function
    
       Sub RotateBitmap (hWnd As Long, hBmp1 As Long, hBmp2 As Long, Angle As Long, cx As Long, cy As Long)
    
          Dim hDC As Long
          hDC = GetDC(hWnd)
    
          Dim hMemDC(2) As Static Long
          hMemDC(1) = CreateCompatibleDC(hDC)
          SelectObject hMemDC(1), hBmp1
          hMemDC(2) = CreateCompatibleDC(hDC)
          SelectObject hMemDC(2), hBmp2
    
          Dim Bm(2) As BITMAP
          Dim pWidth(2) As Static Long, pHeight(2) As Static Long
    
          GetObject hBmp1, SizeOf(bm(1)), bm(1)
          pWidth(1) = bm(1).bmWidth
          pHeight(1) = bm(1).bmHeight
          GetObject hBmp2, SizeOf(bm(2)), bm(2)
          pWidth(2) = bm(2).bmWidth
          pHeight(2) = bm(2).bmHeight
    
          hMemDC(0) = CreateCompatibleDC(hDC)
          Dim bmi As BITMAPINFO, hMemBmp As Long
          bmi.bmiHeader.biSize = SizeOf(bmi.bmiHeader)
          bmi.bmiHeader.biWidth = pWidth(1)
          bmi.bmiHeader.biHeight = pHeight(1)
          bmi.bmiHeader.biPlanes = 1
          bmi.bmiHeader.biBitCount = 32
          bmi.bmiHeader.biCompression = %BI_RGB
          hMemBmp = CreateDIBSection(hMemDC(0), bmi, %DIB_RGB_COLORS, 0, 0, 0)
          GlobalLock hMemBmp
          SelectObject hMemDC(0), hMemBmp
          BitBlt hMemDC(0), 0, 0, pWidth(1), pHeight(1), hMemDC(1), 0, 0, %SRCCOPY
    
          GetObject hMemBmp, SizeOf(bm(0)), bm(0)
    
          Dim ClrL0() As Long: ReDim ClrL0(pWidth(1) - 1, pHeight(1) - 1) At bm(0).bmBits
          Dim ClrL1() As Long: ReDim ClrL1(pWidth(1) - 1, pHeight(1) - 1) At bm(1).bmBits
          Dim ClrL2() As Long: ReDim ClrL2(pWidth(2) - 1, pHeight(2) - 1) At bm(2).bmBits
    
          Dim PI As Double
          Pi# = 3.14159265359
          Dim c2x As Long  ' Center of pic2.
          Dim c2y As Long  '   "
          Dim a As Single     ' Angle of c2 to p2.
          Dim r As Integer    ' Radius from c2 to p2.
          Dim p1x As Long  ' Position on pic1.
          Dim p1y As Long  '   "
          Dim p2x As Long  ' Position on pic2.
          Dim p2y As Long  '
          Dim n   As Long  ' Max width or height of pic2.
    
          ' Compute the centers
          c2x = pWidth(2) / 2: c2y = pHeight(2) / 2
          
          Dim cc As Long
          cc = ClrL2(0, pHeight(2) - 1)
    
          ' Compute the image size.
          n = Min(pWidth(1), pHeight(1))
          n = n / 2 - 1
          
          ' For each pixel position on pic1
          For p1x = 0 To n
             For p1y = 0 To n
                ' Compute polar coordinate of p2.
                If p1x = 0 Then
                   a = Pi# / 2
                Else
                   a = Atn(p1y / p1x)
                End If
                r = Sqr(1& * p1x * p1x + 1& * p1y * p1y)
    
                Dim theta As Double
                theta = PI# * 2 * Angle / 360
                ' Compute rotated position of p1.
                p2x = r * Cos(a + theta)
                p2y = r * Sin(a + theta)
    
                ' Copy pixels, 4 quadrants at once.
                Dim i As Long, xs As Long, ys As Long, xd As Long, yd As Long, ct As Long
                For i = 1 To 4
                   If i = 1 Then xs = c2x + p2x: ys = c2y + p2y: xd = cx + p1x: yd = cy + p1y Else _
                   If i = 2 Then xs = c2x - p2x: ys = c2y - p2y: xd = cx - p1x: yd = cy - p1y Else _
                   If i = 3 Then xs = c2x + p2y: ys = c2y - p2x: xd = cx + p1y: yd = cy - p1x Else _
                                 xs = c2x - p2y: ys = c2y + p2x: xd = cx - p1y: yd = cy + p1x
               
                   If     (xs < 0) Or (xs > (pWidth(2)  - 1)) Then
                   ElseIf (ys < 0) Or (ys > (pHeight(2) - 1)) Then
                   ElseIf (xd < 0) Or (xd > (pWidth(1)  - 1)) Then
                   ElseIf (yd < 0) Or (yd > (pHeight(1) - 1)) Then
                   Else
                      ct = ClrL2(xs, (pHeight(2) - 1) - ys)
                      If (ct <> cc) Or IsFalse(%RotateTransp) Then ClrL0(xd, (pHeight(1) - 1) - yd) = ct
                   End If
                Next
             Next
          Next
          BitBlt hDC, 0, 0, pWidth(1), pHeight(1), hMemDC(0), 0, 0, %SRCCOPY
    
          DeleteDC hMemDC(0)
          DeleteDC hMemDC(1)
          DeleteDC hMemDC(2)
          DeleteObject hMemBmp
          ReleaseDC hWnd, hDC
    
       End Sub
    
       CallBack  Function DlgProc1
           Select Case CbMsg
              Case %WM_INITDIALOG
                 Dim rc As Static RECT, hBmp1 As Static Long, hBmp2 As Static Long, Angle As Static Long
                 GetClientRect CbHndl, rc
                 hBmp1 = LoadImage(ByVal %NULL, $FileBmp1, %IMAGE_BITMAP, rc.nRight, rc.nBottom, %LR_LOADFROMFILE)
                 hBmp2 = LoadImage(ByVal %NULL, $FileBmp2, %IMAGE_BITMAP, _
                    0.01 * %SizeX2 * rc.nRight, 0.01 * %SizeY2 * rc.nBottom, %LR_LOADFROMFILE)
                 hBmp1 = hBmpDIB32(hBmp1)
                 hBmp2 = hBmpDIB32(hBmp2)
    
                 SetTimer CbHndl, 1, 50, ByVal 0&
    
              Case %WM_TIMER
                 RotateBitmap CbHndl, hBmp1, hBmp2, Angle, 0.01 * %CenterX2 * rc.nRight, 0.01 * %CenterY2 * rc.nBottom
                 Angle = ((Angle + %Angle) Mod 360)
                 SetTimer CbHndl, 1, %Speed, ByVal 0&
    
              Case %WM_DESTROY
                 DeleteObject hBmp1
                 DeleteObject hBmp2
           End Select
       End Function
    
       CallBack  Function DlgProc
          Static hDlg1 As Long
          Select Case CbMsg
             Case %WM_INITDIALOG
                %ID_START = 101
                %ID_STOP = 102
                Control Add Button, CbHndl, %ID_START, "Start", 250, 10, 110, 14
                Control Add Button, CbHndl, %ID_STOP, "Stop", 250, 30, 110, 14
             Case %WM_COMMAND
                Select Case CbCtl
                   Case %ID_START
                      Dialog New CbHndl, "", 10, 10, 200, 200, %WS_CHILD Or %WS_VISIBLE, %WS_EX_CLIENTEDGE To hDlg1
                      Dialog Show Modeless hDlg1 Call DlgProc1
                   Case %ID_STOP
                      If hDlg1 Then Dialog End hDlg1: hDlg1 = 0
                End Select
          End Select
       End Function
    
       Function PbMain()
         Local hDlg As Long
         Dialog New 0 ,"Hello", , , 400, 260, %WS_CAPTION Or %WS_SYSMENU To hDlg
         Dialog Show Modal hDlg Call DlgProc
      End Function
    ------------------
    E-MAIL: [email protected]

  • #2
    This code allows to scroll bitmap.
    Code:
       #Compile Exe
       #Register None
       #Dim All
       #Include "win32api.inc"
    
       Global OldDlgProc1 As Long
    
       CallBack Function DlgProc1
          Dim hMemDC As Static Long, hMemBmp As Static Long, Bm As Static BITMAP
          Dim si(1) As Static SCROLLINFO, szPg(1) As Static Long, szBm(1) As Static Long, CurrentScroll(1) As Static Long
          Dim rc As RECT, i As Long, j As Long, ps As PAINTSTRUCT, Delta(1) As Long
    
          Select Case CbMsg
             Case %WM_GETDLGCODE: Function =  %DLGC_WANTARROWS: Exit Function
                  
             Case %WM_KEYDOWN
                If (CbWparam = %VK_PGDN)  Then PostMessage CbHndl, %WM_VSCROLL, %SB_PAGEDOWN, 0
                If (CbWparam = %VK_PGUP)  Then PostMessage CbHndl, %WM_VSCROLL, %SB_PAGEUP, 0
    
                If (CbWparam = %VK_HOME)  Then PostMessage CbHndl, %WM_HSCROLL, %SB_PAGELEFT, 0
                If (CbWparam = %VK_END)   Then PostMessage CbHndl, %WM_HSCROLL, %SB_PAGERIGHT, 0
    
                If (CbWparam = %VK_UP)    Then PostMessage CbHndl, %WM_VSCROLL, %SB_LINEUP, 0
                If (CbWparam = %VK_DOWN)  Then PostMessage CbHndl, %WM_VSCROLL, %SB_LINEDOWN, 0
    
                If (CbWparam = %VK_LEFT)  Then PostMessage CbHndl, %WM_HSCROLL, %SB_LINEUP, 0
                If (CbWparam = %VK_RIGHT) Then PostMessage CbHndl, %WM_HSCROLL, %SB_LINEDOWN, 0
    
             Case %WM_DESTROY
                DeleteDC hMemDC
                DeleteObject hMemBmp
    
             Case %WM_USER + 1
                hMemDC = CbWparam
                hMemBmp = GetCurrentObject (hMemDC, %OBJ_BITMAP)
                GetObject hMemBmp, SizeOf(Bm), Bm
               
                szBm(0) = bm.bmWidth
                szBm(1) = bm.bmHeight
    
                GetClientRect CbHndl, rc
                szPg(0) = rc.nRight - rc.nLeft
                szPg(1) = rc.nBottom - rc.nTop
    
                For i = 0 To 1
                   si(i).cbSize = SizeOf(si(i))
                   si(i).fMask  = %SIF_ALL
                   si(i).nMax   = szBm(i)
                   si(i).nPage  = szPg(i)
                   If i = 0 Then j = %SB_HORZ Else j = %SB_VERT
                   SetScrollInfo CbHndl, j, si(i), 1
                Next
    
                SetFocus CbHndl
    
             Case %WM_PAINT
                BeginPaint CbHndl, ps
                BitBlt ps.hdc, ps.rcPaint.nLeft, ps.rcPaint.ntop, ps.rcPaint.nRight - ps.rcPaint.nLeft, _
                   ps.rcPaint.nbottom - ps.rcPaint.ntop, _
                   hMemDC, ps.rcPaint.nLeft + CurrentScroll(0), ps.rcPaint.ntop + CurrentScroll(1), %SRCCOPY
                EndPaint CbHndl, ps
    
             Case %WM_HSCROLL, %WM_VSCROLL
                If CbMsg = %WM_HSCROLL Then i = 0 Else i = 1
                
                Select Case LoWrd(CbWparam)
                   Case %SB_PAGEUP       : j = CurrentScroll(i) - si(i).nPage
                   Case %SB_PAGEDOWN     : j = CurrentScroll(i) + si(i).nPage
                   Case %SB_LINEUP       : j = CurrentScroll(i) - 0.1 * si(i).nPage
                   Case %SB_LINEDOWN     : j = CurrentScroll(i) + 0.1 * si(i).nPage
                   Case %SB_THUMBPOSITION: j = HiWrd(CbWparam)
                   Case Else             : j = CurrentScroll(i)
                End Select
                
                j = Max(0, j): j = Min(Max(szBm(i) - szPg(i), 0), j)
                If j = CurrentScroll(i) Then Exit Function
                Delta(i) = j - CurrentScroll(i)
                CurrentScroll(i) = j
    
                ScrollWindowEx  CbHndl, -Delta(0), -Delta(1), ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, %SW_INVALIDATE
                UpdateWindow CbHndl
    
                si(i).nPos   = CurrentScroll(i)
                If i = 0 Then j = %SB_HORZ Else j = %SB_VERT
                SetScrollInfo CbHndl, j, si(i), 1
    
            Case %WM_ERASEBKGND
                Function = 1
          End Select
       
          Function = CallWindowProc(OldDlgProc1, CbHndl, CbMsg, CbWparam, CbLparam)
     
       End Function
    
       Function CreateHdcFromDesktop As Long
          
          Dim hDC As Long, hMemDC As Long, hWnd As Long, bmp As BITMAP, hMemBmp As Long, hBmpOld As Long
    
          hWnd = GetDesktopWindow
          hDC = GetWindowDC(hWnd)
    
          bmp.bmBitsPixel = GetDeviceCaps(hdc, %BITSPIXEL)
          bmp.bmPlanes =  GetDeviceCaps(hdc, %PLANES)
          bmp.bmWidth = GetDeviceCaps(hdc, %HORZRES)
          bmp.bmHeight = GetDeviceCaps(hdc, %VERTRES)
          bmp.bmWidthBytes = Fix((bmp.bmWidth + 15) / 16) * 2
    
          hMemBmp = CreateBitmap(bmp.bmWidth, bmp.bmHeight, bmp.bmPlanes, bmp.bmBitsPixel, ByVal 0&)
          hMemDC = CreateCompatibleDC (hDC)
          hBmpOld = SelectObject (hMemDC, hMemBmp)
          BitBlt hMemDC, 0, 0, bmp.bmWidth, bmp.bmHeight, hdc, 0, 0, %SRCCOPY
          ReleaseDC hWnd, hDC
    
          Function = hMemDC
          
       End Function
    
       %ID_SHOWPIC = 101
       %ID_HIDEPIC = 102
    
       CallBack Function DlgProc
          Select Case CbMsg
             Case %WM_INITDIALOG
                Control Add Button, CbHndl, %ID_SHOWPIC, "Show", 10, 10, 100, 15
                Control Add Button, CbHndl, %ID_HIDEPIC, "Hide", 10, 30, 100, 15
                
             Case %WM_COMMAND
                If CbCtl = %ID_SHOWPIC Then
                   Dim hDlg1 As Static Long, hMemDC As Long
                   If IsFalse(hDlg1) Then
                      hMemDC = CreateHdcFromDesktop
                      Dialog New CbHndl, "", 10, 50, 280, 200, %WS_TABSTOP Or %WS_HSCROLL Or %WS_VSCROLL Or %WS_CHILD Or %WS_TABSTOP, %WS_EX_CLIENTEDGE To hDlg1
                      OldDlgProc1 = SetWindowLong(hDlg1, %GWL_WNDPROC, CodePtr(Dlgproc1))
                      PostMessage hDlg1, %WM_USER + 1, hMemDC, 0
                   End If
                   Dialog Show Modeless hDlg1
                ElseIf CbCtl = %ID_HIDEPIC Then
                   If hDlg1 Then Dialog End hDlg1: hDlg1 = 0
                End If
          End Select
       End Function
    
       Function PbMain()
    
          Dim hDlg As Long
          Dialog New %HWND_DESKTOP, "Scroll BitMap", , , 300, 300, %WS_CAPTION Or %WS_SYSMENU To hDlg
          Dialog Show Modal hDlg Call DlgProc
    
      End Function
    ------------------
    E-MAIL: [email protected]

    Comment

    Working...
    X