06-13-2024, 04:16 PM (This post was last modified: 06-13-2024, 04:18 PM by Kernelpanic.)
At last a small, successful exercise (would a sub-form of exercises make sense?). A standard program with a picture on the side and a gimmick with color and font.
The program calculates the piston speed of an engine. According to Hütten, engines with a piston speed of over 21 meters per second are in danger of flying apart. The book is 40 years old, wether is that still true today? Maybe!
'Kolbengeschwindigkeit berechnen - 13. Juni 2024
'Uebung wie man Text und Bild einfuegt
Screen _NewImage(650, 420, 32)
$Color:32
Option _Explicit
Dim As Double kolbenhub, drehzahl, kolbenges
Dim As Long Bild, myFont
Dim As String Text
Bild = _LoadImage("..\..\Bilder\Zweitackter.gif") 'Siehe Hinweis unten um das Bild zu erhalten
_PutImage (470, 35), Bild 'Platzierung des Bildes. Haengt von der Fenstergroesse ab
Locate 5, 3
Input "Kolbenhub in cm : ", kolbenhub
Locate 6, 3
Input "Motordrehzahl bei hoechster Leistung: ", drehzahl
'Formel fuer die Kolbengeschwindigkeit - H. Huetten
kolbenges = (((2 * kolbenhub) * drehzahl) / (60 * 100))
If kolbenges <= 21 Then
Locate 8, 3
Print Using "Die Kolbengeschwindigkeit betraegt : ##.##"; kolbenges
Else
Locate 8, 3
Beep: Color Red, 0
Print Using "Die Kolbengeschwindigkeit liegt ueber 21 m/sec: ##.##"; kolbenges
Locate 9, 3
Color White, 0
Print "(Bei Dauerbelastung droht Gefahr fuer den Motor!)"
End If
Text = "Bild von A. Schierwagen, GNU-Lizens - Wikipedia"
myFont = _LoadFont("C:\Windows\Fonts\Dauphinn.ttf", 15, "")
_Font myFont
(06-13-2024, 04:16 PM)Kernelpanik Wrote: Es ist ein animiertes GIF. Gibt es eine Möglichkeit, die Animation abzurufen? Ich habe nichts gefunden - oder es nicht verstanden.
Maybe this can help you, it's not mine but it works
' Open gif file. This reads the headers and palette but not the image data. ' The array will be redimentioned to fit the exact number of frames in the file.
Dim gifData As GIFDATA, frameData(0To0) As FRAMEDATA
'filename$ = "maygif-11.gif" '<<<<<<<<<<<< Enter a file name here!!!
filename$ = _OpenFileDialog$("Datei Öffnen", "", "*.gif", "Bilddatei", 0) IfLen(filename$) = 0ThenEnd openGif filename$, gifData, frameData()
For i = 1To100 ' Request a frame. If it has been requested before, it is re-used, ' otherwise it is read and decoded from the file. _PutImage (80, 80), getGifFrame&(gifData, frameData(), frame) _Delay frameData(frame).delay
frame = (frame + 1) Mod (UBound(frameData) + 1) Next i Loop UntilLen(InKey$)
'Close the file and free the allocated frames. codeGif gifData, frameData() IfInKey$ = Chr$(27) ThenSystem Run
If frameData(frame).transparentFlag Then _ClearColor frameData(frame).transColor, img& End If _PutImage (frameData(frame).left, frameData(frame).top), img& _FreeImage img&
lastColor = code
colorStack(stackPointer) = lastColor
stackPointer = 1 ElseIf code <> endCode Then'Draw direct color or colors from suffix
currentCode = code If currentCode = nvc Then'Take last color too
currentCode = oldCode
colorStack(stackPointer) = lastColor
stackPointer = stackPointer + 1 End If
While currentCode >= minCode 'Extract colors from suffix
colorStack(stackPointer) = suffix(currentCode)
stackPointer = stackPointer + 1
currentCode = prefix(currentCode) 'Next color from suffix is described in Wend' the prefix, else prefix is the last col.
lastColor = currentCode ' Last color is equal to the
colorStack(stackPointer) = lastColor ' last known code (direct, or from
stackPointer = stackPointer + 1' Prefix)
suffix(nvc) = lastColor 'Automatically, update suffix
prefix(nvc) = oldCode 'Code from the session before (for extracting from suffix)
nvc = nvc + 1
If nvc > maxCode And codeSize < 12Then
codeSize = codeSize + 1
maxCode = maxCode * 2 + 1 End If End If
For i = stackPointer - 1To0Step-1 PSet (x, y), colorStack(i)
x = x + 1 If x = framedata.width Then
x = 0 If framedata.interlacedFlag Then
y = y + interlacedStep If y >= framedata.height Then Select Case interlacedPass Case0: interlacedPass = 1: y = 4 Case1: interlacedPass = 2: y = 2 Case2: interlacedPass = 3: y = 1 End Select
interlacedStep = 2 * y End If Else
y = y + 1 End If End If Next
ReadByteFromBlock: If blockPointer = blockSize Then Get file, , byte: blockSize = byte
a$ = Space$(blockSize): Get file, , a$
blockPointer = 0 End If
blockPointer = blockPointer + 1
LastChar = Asc(Mid$(a$, blockPointer, 1)) Return End Sub
06-13-2024, 08:36 PM (This post was last modified: 06-13-2024, 08:37 PM by Kernelpanic.)
An inaccuracy. This is easier to understand:
Code: (Select All)
If kolbenges <= 21 Then
Locate 8, 3
Print Using "Die Kolbengeschwindigkeit betraegt : ##.##"; kolbenges;
Print " m/sec"
Else
Quote:Maybe this can help you, it's not mine but it works
Thanks! Looks enormous. - I don't really understand the effort involved. Doesn't a GIF image basically run by itself? How do one do it in an image viewer, such as XnView?
06-13-2024, 10:24 PM (This post was last modified: 06-13-2024, 10:52 PM by bplus.)
just add your code to the code steffan-68 provided for displaying the gif
Like this:
Code: (Select All)
'$Dynamic
Dim Shared Dbg: Dbg = 0
Dim Shared powerOf2&(11)
For a = 0 To 11: powerOf2&(a) = 2 ^ a: Next a
Type GIFDATA
file As Integer
sigver As String * 6
width As _Unsigned Integer
height As _Unsigned Integer
bpp As _Unsigned _Byte
sortFlag As _Byte ' Unused
colorRes As _Unsigned _Byte
colorTableFlag As _Byte
bgColor As _Unsigned _Byte
aspect As Single ' Unused
numColors As _Unsigned Integer
palette As String * 768
End Type
Type FRAMEDATA
addr As Long
left As _Unsigned Integer
top As _Unsigned Integer
width As _Unsigned Integer
height As _Unsigned Integer
localColorTableFlag As _Byte
interlacedFlag As _Byte
sortFlag As _Byte ' Unused
palBPP As _Unsigned _Byte
minimumCodeSize As _Unsigned _Byte
transparentFlag As _Byte 'GIF89a-specific (animation) values
userInput As _Byte ' Unused
disposalMethod As _Unsigned _Byte
delay As Single
transColor As _Unsigned _Byte
End Type
Dim gifData As GIFDATA, frameData(0 To 0) As FRAMEDATA
'Kolbengeschwindigkeit berechnen - 13. Juni 2024
'Uebung wie man Text und Bild einfuegt
Screen _NewImage(650, 420, 32)
$Color:32
Dim As Double kolbenhub, drehzahl, kolbenges
Dim As Long Bild, myFont
Dim As String Text
'Bild = _LoadImage("..\..\Bilder\Zweitackter.gif") 'Siehe Hinweis unten um das Bild zu erhalten
'_PutImage (470, 35), Bild 'Platzierung des Bildes. Haengt von der Fenstergroesse ab
Locate 5, 3
Input "Kolbenhub in cm : ", kolbenhub
Locate 6, 3
Input "Motordrehzahl bei hoechster Leistung: ", drehzahl
'Formel fuer die Kolbengeschwindigkeit - H. Huetten
kolbenges = (((2 * kolbenhub) * drehzahl) / (60 * 100))
If kolbenges <= 21 Then
Locate 8, 3
Print Using "Die Kolbengeschwindigkeit betraegt : ##.##"; kolbenges
Else
Locate 8, 3
Beep: Color Red, 0
Print Using "Die Kolbengeschwindigkeit liegt ueber 21 m/sec: ##.##"; kolbenges
Locate 9, 3
Color White, 0
Print "(Bei Dauerbelastung droht Gefahr fuer den Motor!)"
End If
Text = "Bild von A. Schierwagen, GNU-Lizens - Wikipedia"
'myFont = _LoadFont("C:\Windows\Fonts\Dauphinn.ttf", 15, "")
myFont = _LoadFont("C:\Windows\Fonts\ARIAL.ttf", 15, "")
_Font myFont
'Spalte - Zeile (Umgekehrt wie bei Locate)
_PrintString (360, 340), Text
'Farbe und Schrift zuruecksetzen
Color _RGB32(255), _RGB32(0, 0, 0)
_Font 16
_FreeFont myFont
frame = 0
Do
For i = 1 To 100
' Request a frame. If it has been requested before, it is re-used,
' otherwise it is read and decoded from the file.
_PutImage (470, 35), getGifFrame&(gifData, frameData(), frame)
_Delay frameData(frame).delay
frame = (frame + 1) Mod (UBound(frameData) + 1)
Next i
Loop Until Len(InKey$)
End
'########################################################################################
Sub openGif (filename$, gifData As GIFDATA, frameData() As FRAMEDATA) Static
file = FreeFile: gifData.file = file
Open "B", gifData.file, filename$
Get file, , gifData.sigver
Get file, , gifData.width
Get file, , gifData.height
Get file, , byte~%%
gifData.bpp = (byte~%% And 7) + 1
gifData.sortFlag = (byte~%% And 8) > 0
gifData.colorRes = (byte~%% \ 16 And 7) + 1
gifData.colorTableFlag = (byte~%% And 128) > 0
gifData.numColors = 2 ^ gifData.bpp
Get file, , gifData.bgColor
Get file, , byte~%%
If byte~%% = 0 Then gifData.aspect = 0 Else gifData.aspect = (byte~%% + 15) / 64
If gifData.sigver <> "GIF87a" And gifData.sigver <> "GIF89a" Then _Dest 0: Print "Invalid version": End
If Not gifData.colorTableFlag Then _Dest 0: Print "No Color Table": End
palette$ = Space$(3 * gifData.numColors)
Get file, , palette$
gifData.palette = palette$
If Dbg And 1 Then
Print "sigver ="; gifData.sigver
Print "width ="; gifData.width
Print "height ="; gifData.height
Print "bpp ="; gifData.bpp
Print "sortFlag ="; gifData.sortFlag
Print "colorRes ="; gifData.colorRes
Print "colorTableFlag ="; gifData.colorTableFlag
Print "bgColor ="; gifData.bgColor
Print "aspect ="; gifData.aspect
Print "numColors ="; gifData.numColors
For i = 0 To gifData.numColors - 1
Print Using "pal(###) = "; i;
Print Hex$(_RGB32(Asc(gifData.palette, i * 3 + 1), Asc(gifData.palette, i * 3 + 2), Asc(gifData.palette, i * 3 + 3)))
Next
End If
Do
Get file, , byte~%%
If Dbg And 2 Then Print "Chunk: "; Hex$(byte~%%)
Select Case byte~%%
Case &H2C ' Image Descriptor
If frame > UBound(frameData) Then
ReDim _Preserve frameData(0 To frame * 2 - 1) As FRAMEDATA
End If
Get file, , frameData(frame).left
Get file, , frameData(frame).top
Get file, , frameData(frame).width
Get file, , frameData(frame).height
Get file, , byte~%%
frameData(frame).localColorTableFlag = (byte~%% And 128) > 0
frameData(frame).interlacedFlag = (byte~%% And 64) > 0
frameData(frame).sortFlag = (byte~%% And 32) > 0
frameData(frame).palBPP = (byte~%% And 7) + 1
frameData(frame).addr = Loc(file) + 1
If frameData(frame).localColorTableFlag Then
Seek file, Loc(file) + 3 * 2 ^ frameData(frame).palBPP + 1
End If
Get file, , frameData(frame).minimumCodeSize
If Dbg And 2 Then
Print "addr ="; Hex$(frameData(frame).addr - 1)
Print "left ="; frameData(frame).left
Print "top ="; frameData(frame).top
Print "width ="; frameData(frame).width
Print "height ="; frameData(frame).height
Print "localColorTableFlag ="; frameData(frame).localColorTableFlag
Print "interlacedFlag ="; frameData(frame).interlacedFlag
Print "sortFlag ="; frameData(frame).sortFlag
Print "palBPP ="; frameData(frame).palBPP
Print "minimumCodeSize ="; frameData(frame).minimumCodeSize
End If
If localColors Then _Dest 0: Print "Local color table": End
If frameData(frame).disposalMethod > 2 Then Print "Unsupported disposalMethod: "; frameData(frame).disposalMethod: End
skipBlocks file
frame = frame + 1
Case &H3B ' Trailer
Exit Do
Case &H21 ' Extension Introducer
Get file, , byte~%% ' Extension Label
If Dbg And 2 Then Print "Extension Introducer: "; Hex$(byte~%%)
Select Case byte~%%
Case &HFF, &HFE ' Application Extension, Comment Extension
skipBlocks file
Case &HF9
If frame > UBound(frameData) Then
ReDim _Preserve frameData(0 To frame * 2 - 1) As FRAMEDATA
End If
Get 1, , byte~%% ' Block Size (always 4)
Get 1, , byte~%%
frameData(frame).transparentFlag = (byte~%% And 1) > 0
frameData(frame).userInput = (byte~%% And 2) > 0
frameData(frame).disposalMethod = byte~%% \ 4 And 7
Get 1, , delay~%
If delay~% = 0 Then frameData(frame).delay = 0.1 Else frameData(frame).delay = delay~% / 100
Get 1, , frameData(frame).transColor
If Dbg And 2 Then
Print "frame ="; frame
Print "transparentFlag ="; frameData(frame).transparentFlag
Print "userInput ="; frameData(frame).userInput
Print "disposalMethod ="; frameData(frame).disposalMethod
Print "delay ="; frameData(frame).delay
Print "transColor ="; frameData(frame).transColor
End If
skipBlocks file
Case Else
Print "Unsupported extension Label: "; Hex$(byte~%%): End
End Select
Case Else
Print "Unsupported chunk: "; Hex$(byte~%%): End
End Select
Loop
ReDim _Preserve frameData(0 To frame - 1) As FRAMEDATA
End Sub
Sub skipBlocks (file)
Do
Get file, , byte~%% ' Block Size
If Dbg And 2 Then Print "block size ="; byte~%%
Seek file, Loc(file) + byte~%% + 1
Loop While byte~%%
End Sub
Function getGifFrame& (gifData As GIFDATA, frameData() As FRAMEDATA, frame)
If frameData(frame).addr > 0 Then
If Dbg And 4 Then
Print "addr ="; Hex$(frameData(frame).addr - 1)
Print "left ="; frameData(frame).left
Print "top ="; frameData(frame).top
Print "width ="; frameData(frame).width
Print "height ="; frameData(frame).height
Print "localColorTableFlag ="; frameData(frame).localColorTableFlag
Print "interlacedFlag ="; frameData(frame).interlacedFlag
Print "sortFlag ="; frameData(frame).sortFlag
Print "palBPP ="; frameData(frame).palBPP
Print "minimumCodeSize ="; frameData(frame).minimumCodeSize
Print "transparentFlag ="; frameData(frame).transparentFlag
Print "userInput ="; frameData(frame).userInput
Print "disposalMethod ="; frameData(frame).disposalMethod
Print "delay ="; frameData(frame).delay
Print "transColor ="; frameData(frame).transColor
End If
w = frameData(frame).width
h = frameData(frame).height
img& = _NewImage(w, h, 256)
frame& = _NewImage(gifData.width, gifData.height, 256)
_Dest img&
decodeFrame gifData, frameData(frame)
_Dest frame&
If frameData(frame).localColorTableFlag Then
_CopyPalette img&
Else
For i = 0 To gifData.numColors - 1
_PaletteColor i, _RGB32(Asc(gifData.palette, i * 3 + 1), Asc(gifData.palette, i * 3 + 2), Asc(gifData.palette, i * 3 + 3))
Next
End If
If frame Then
Select Case frameData(frame - 1).disposalMethod
Case 0, 1
_PutImage , frameData(frame - 1).addr
Case 2
Cls , gifData.bgColor
_ClearColor gifData.bgColor
End Select
Else
Cls , gifData.bgColor
End If
If frameData(frame).transparentFlag Then
_ClearColor frameData(frame).transColor, img&
End If
_PutImage (frameData(frame).left, frameData(frame).top), img&
_FreeImage img&
frameData(frame).addr = frame&
_Dest 0
End If
getGifFrame& = frameData(frame).addr
End Function
'############################################################################################
Sub decodeFrame (gifdata As GIFDATA, framedata As FRAMEDATA)
Dim byte As _Unsigned _Byte
Dim prefix(4095), suffix(4095), colorStack(4095)
startCodeSize = gifdata.bpp + 1
clearCode = 2 ^ gifdata.bpp
endCode = clearCode + 1
minCode = endCode + 1
startMaxCode = clearCode * 2 - 1
nvc = minCode
codeSize = startCodeSize
maxCode = startMaxCode
If framedata.interlacedFlag Then interlacedPass = 0: interlacedStep = 8
bitPointer = 0
blockSize = 0
blockPointer = 0
x = 0
y = 0
file = gifdata.file
Seek file, framedata.addr
If framedata.localColorTableFlag Then
palette$ = Space$(3 * 2 ^ framedata.palBPP)
Get 1, , palette$
For i = 0 To gifdata.numColors - 1
c& = _RGB32(Asc(palette$, i * 3 + 1), Asc(palette$, i * 3 + 2), Asc(palette$, i * 3 + 3))
_PaletteColor i, c&
Next
End If
Get file, , byte ' minimumCodeSize
Do
GoSub GetCode
stackPointer = 0
If code = clearCode Then 'Reset & Draw next color direct
nvc = minCode ' \
codeSize = startCodeSize ' Preset default codes
maxCode = startMaxCode ' /
GoSub GetCode
currentCode = code
lastColor = code
colorStack(stackPointer) = lastColor
stackPointer = 1
ElseIf code <> endCode Then 'Draw direct color or colors from suffix
currentCode = code
If currentCode = nvc Then 'Take last color too
currentCode = oldCode
colorStack(stackPointer) = lastColor
stackPointer = stackPointer + 1
End If
While currentCode >= minCode 'Extract colors from suffix
colorStack(stackPointer) = suffix(currentCode)
stackPointer = stackPointer + 1
currentCode = prefix(currentCode) 'Next color from suffix is described in
Wend ' the prefix, else prefix is the last col.
lastColor = currentCode ' Last color is equal to the
colorStack(stackPointer) = lastColor ' last known code (direct, or from
stackPointer = stackPointer + 1 ' Prefix)
suffix(nvc) = lastColor 'Automatically, update suffix
prefix(nvc) = oldCode 'Code from the session before (for extracting from suffix)
nvc = nvc + 1
If nvc > maxCode And codeSize < 12 Then
codeSize = codeSize + 1
maxCode = maxCode * 2 + 1
End If
End If
For i = stackPointer - 1 To 0 Step -1
PSet (x, y), colorStack(i)
x = x + 1
If x = framedata.width Then
x = 0
If framedata.interlacedFlag Then
y = y + interlacedStep
If y >= framedata.height Then
Select Case interlacedPass
Case 0: interlacedPass = 1: y = 4
Case 1: interlacedPass = 2: y = 2
Case 2: interlacedPass = 3: y = 1
End Select
interlacedStep = 2 * y
End If
Else
y = y + 1
End If
End If
Next
oldCode = code
Loop Until code = endCode
Get file, , byte
Exit Sub
GetCode:
If bitPointer = 0 Then GoSub ReadByteFromBlock: bitPointer = 8
WorkCode& = LastChar \ powerOf2&(8 - bitPointer)
While codeSize > bitPointer
GoSub ReadByteFromBlock
WorkCode& = WorkCode& Or LastChar * powerOf2&(bitPointer)
bitPointer = bitPointer + 8
Wend
bitPointer = bitPointer - codeSize
code = WorkCode& And maxCode
Return
ReadByteFromBlock:
If blockPointer = blockSize Then
Get file, , byte: blockSize = byte
a$ = Space$(blockSize): Get file, , a$
blockPointer = 0
End If
blockPointer = blockPointer + 1
LastChar = Asc(Mid$(a$, blockPointer, 1))
Return
End Sub
Sub codeGif (gifData As GIFDATA, frameData() As FRAMEDATA)
For i = 0 To UBound(frameData)
If frameData(i).addr < 0 Then _FreeImage frameData(i).addr
Next
Close gifData.file
End Sub
(06-14-2024, 08:09 PM)Kernelpanic Wrote: Now it works, Thanks. I had to make a few changes. Great program, but mighty mighty. The programmer seems to be German.
![[Image: Bild-mit-Text2024-06-13.jpg]](https://i.ibb.co/9yQmtTx/Bild-mit-Text2024-06-13.jpg)
![[Image: icon-lol.gif]](https://i.ibb.co/nMgJ8f6/icon-lol.gif){kind=icon}