QB64PE v4.0 is now live!! - Printable Version

'Tenaeren Operator in QB64 ab Vers. 4.0 - 16. Dez. 2024 'Dank an a740g und RhoSigma - 17. Dez 2024 Option _Explicit Dim As Long zahl1, zahl2, zahl3, max Locate 3, 3 Print "Dreifach tenaerer Operator in QB64" Locate 4, 3 Print "==================================" Locate 6, 3 Input "Zahl 1: ", zahl1 Locate 7, 3 Input "Zahl 2: ", zahl2 Locate 8, 3 Input "Zahl 3: ", zahl3 max = _Max(_Max(zahl1, zahl2), zahl3) Locate 10, 3 Print Using "Die groesste Zahl ist: ####"; max End
Code: (Select All)
Screen _NewImage(1280, 720, 32)

Cls , _RGB32(255, 255, 0)



For i = 1 To 20

    Line (Rnd * 1280, Rnd * 720)-(Rnd * 1280, Rnd * 720), _RGB32(Rnd * 256, Rnd * 256, Rnd * 256), BF

Next





t# = Timer

Save32 0, 0, 1279, 719, 0, "temp.bmp"

t1# = Timer

ThirtyTwoBit 0, 0, 1279, 719, 0, "temp2.bmp"

t2# = Timer

Print Using "###.### seconds with Save32"; t1# - t#

Print Using "###.### seconds with ThirtyTwoBit"; t2# - t1#

'KILL "temp.bmp"

'KILL "temp2.bmp"





Sub Save32 (x1%, y1%, x2%, y2%, image&, Filename$)

    'Super special STEVE-Approved BMP Export routine for use with 32-bit color images.





    Type BMPFormat ' Description                          Bytes    QB64 Function

        ID As String * 2 ' File ID("BM" text or 19778 AS Integer) 2      CVI("BM")

        Size As Long ' Total Size of the file                4      LOF

        Blank As Long ' Reserved                              4

        Offset As Long ' Start offset of image pixel data      4      (add one for GET)

        Hsize As Long ' Info header size (always 40)          4

        PWidth As Long ' Image width                            4      _WIDTH(handle&)

        PDepth As Long ' Image height (doubled in icons)        4      _HEIGHT(handle&)

        Planes As Integer ' Number of planes (normally 1)          2

        BPP As Integer ' Bits per pixel(palette 1, 4, 8, 24)    2      _PIXELSIZE(handle&)

        Compression As Long ' Compression type(normally 0)          4

        ImageBytes As Long ' (Width + padder) * Height              4

        Xres As Long ' Width in PELS per metre(normally 0)    4

        Yres As Long ' Depth in PELS per metre(normally 0)    4

        NumColors As Long ' Number of Colors(normally 0)          4      2 ^ BPP

        SigColors As Long ' Significant Colors(normally 0)        4

    End Type '                Total Header bytes =  54



    Dim BMP As BMPFormat

    Dim x As Long, y As Long

    Dim temp As String * 3

    Dim m As _MEM, n As _MEM

    Dim o As _Offset

    m = _MemImage(image&)

    Dim Colors8%(255)



    If x1% > x2% Then Swap x1%, x2%

    If y1% > y2% Then Swap y1%, y2%

    _Source image&

    pixelbytes& = 4

    OffsetBITS& = 54 'no palette in 24/32 bit

    BPP% = 24

    NumColors& = 0 '24/32 bit say zero

    BMP.PWidth = (x2% - x1%) + 1

    BMP.PDepth = (y2% - y1%) + 1



    ImageSize& = BMP.PWidth * BMP.PDepth



    BMP.ID = "BM"

    BMP.Size = ImageSize& * 3 + 54

    BMP.Blank = 0

    BMP.Offset = 54

    BMP.Hsize = 40

    BMP.Planes = 1

    BMP.BPP = 24

    BMP.Compression = 0

    BMP.ImageBytes = ImageSize&

    BMP.Xres = 3780

    BMP.Yres = 3780

    BMP.NumColors = 0

    BMP.SigColors = 0



    Compression& = 0

    WidthPELS& = 3780

    DepthPELS& = 3780

    SigColors& = 0

    f = FreeFile

    n = _MemNew(BMP.Size)

    _MemPut n, n.OFFSET, BMP

    o = n.OFFSET + 54



    $Checking:Off

    y = y2% + 1

    w& = _Width(image&)

    Do

        y = y - 1: x = x1% - 1

        Do

            x = x + 1

            _MemGet m, m.OFFSET + (w& * y + x) * 4, temp

            _MemPut n, o, temp

            o = o + 3

        Loop Until x = x2%

    Loop Until y = y1%

    $Checking:On

    _MemFree m

    Open Filename$ For Binary As #f

    t$ = Space$(BMP.Size)

    _MemGet n, n.OFFSET, t$

    Put #f, , t$

    _MemFree n

    Close #f

End Sub





Sub ThirtyTwoBit (x1%, y1%, x2%, y2%, image&, Filename$)

    Dim Colors8%(255)

    If x1% > x2% Then Swap x1%, x2%

    If y1% > y2% Then Swap y1%, y2%

    _Source image&

    pixelbytes& = _PixelSize(image&)

    If pixelbytes& = 0 Then Beep: Exit Sub 'no text screens



    FileType$ = "BM"

    QB64$ = "QB64" 'free advertiising in reserved bytes

    If pixelbytes& = 1 Then OffsetBITS& = 1078 Else OffsetBITS& = 54 'no palette in 24/32 bit

    InfoHEADER& = 40

    PictureWidth& = (x2% - x1%) + 1

    PictureDepth& = (y2% - y1%) + 1

    NumPLANES% = 1

    If pixelbytes& = 1 Then BPP% = 8 Else BPP% = 24

    Compression& = 0

    WidthPELS& = 3780

    DepthPELS& = 3780



    If pixelbytes& = 1 Then 'byte padder prevents image skewing

        NumColors& = 256 'set 256 colors even if they are not used by the screen mode

        If (PictureWidth& Mod 4) Then ZeroPad$ = Space$(4 - (PictureWidth& Mod 4))

    Else '24/32 bit images use 3 bytes for RGB pixel values

        NumColors& = 0 '24/32 bit say zero

        If ((PictureWidth& * 3) Mod 4) Then ZeroPad$ = Space$((4 - ((PictureWidth& * 3) Mod 4)))

    End If



    ImageSize& = (PictureWidth& + Len(ZeroPad$)) * PictureDepth&

    FileSize& = ImageSize& + OffsetBITS&

    f = FreeFile

    Open Filename$ For Binary As #f



    Put #f, , FileType$

    Put #f, , FileSize&

    Put #f, , QB64$

    Put #f, , OffsetBITS&

    Put #f, , InfoHEADER&

    Put #f, , PictureWidth&

    Put #f, , PictureDepth&

    Put #f, , NumPLANES%

    Put #f, , BPP%

    Put #f, , Compression&

    Put #f, , ImageSize&

    Put #f, , WidthPELS&

    Put #f, , DepthPELS&

    Put #f, , NumColors&

    Put #f, , SigColors& '51 offset



    If pixelbytes& = 1 Then '4 or 8 BPP use 256 color Palette

        u$ = Chr$(0)

        For c& = 0 To 255 'PUT as BGR order colors

            cv& = _PaletteColor(c&, image&)

            Colr$ = Chr$(_Blue32(cv&))

            Put #f, , Colr$

            Colr$ = Chr$(_Green32(cv&))

            Put #f, , Colr$

            Colr$ = Chr$(_Red32(cv&))

            Put #f, , Colr$

            Put #f, , u$ 'Unused byte

        Next

    End If



    For y% = y2% To y1% Step -1 'place bottom up

        For x% = x1% To x2%

            c& = Point(x%, y%)

            If pixelbytes& = 1 Then

                a$ = Chr$(c&)

                Colors8%(c&) = 1

            Else: a$ = Left$(MKL$(c&), 3)

            End If

            Put #f, , a$

        Next

        Put #f, , ZeroPad$

    Next



    For n = 0 To 255

        If Colors8%(n) = 1 Then SigColors& = SigColors& + 1

    Next n

    Put #f, 51, SigColors&

    Close #f

End Sub