Visual Basic Forum

PokemonProgrammierer · Newbie Anmeldedatum: 23.07.2010 Beiträge: 14

Ich bedanke mich im voraus an allen Antwortern. Ich bin total verzweifelt Crying or Very sad

.
Ich will gerdade ein neues Pokemon Spiel machen und verzweifle schon seit einer Woche an folgewnder Frage:
Erstmal habe ich den Hauptordner "Pokemon Granit". In diesem Ordner ist erstmal das Perojekt und der Unterordner "Bilder". Ersmal kein Problem aberjetzt kommts: Wink

Im Hauptordner ist die Datei Welt.txt:
Baum1.bmp ; 1 ; 0 ; 0

Baum1.bmp ist eines der Bilder die geladen werden sollen, ferner existieren noch Bilder wie wiese1.bmp usw...
Der Code ist bis jetzt folgender:

Open App.Path + "\Welt.txt" For Input As #1
While Not EOF(1)
Line Input #1, a$
If Trim$(a$) = "" Then GoTo finish
pos% = InStr(a$, ";")
FileName$ = Left(a$, pos% - 1)
a$ = Mid$(a$, pos% + 1)
'_
pos% = InStr(a$, ";")
Was$ = Left(a$, pos% - 1)
a$ = Mid$(a$, pos% + 1)
'_
Mehr:
pos% = InStr(a$, ";")
x$ = Left(a$, pos% - 1)
a$ = Mid$(a$, pos% + 1)
'_
pos% = InStr(a$, ";")
If pos% <> 0 Then
Y$ = Left(a$, pos% - 1)
a$ = Mid$(a$, pos% + 1)
Else
Y$ = a$
a$ = ""
End If
Call setpic(App.Path + "\Bilder\" + FileName$, Was$, x$, Y$)

If Trim$(a$) <> "" Then GoTo Mehr

Wend
finish:
Close #1

End Sub

So das trenn jetzt die ";" raus und nennt sie von Links nach rechts wie folgt: FileName$, Was$, x$ und y$ Idea

So Filename$ ist das Bild das an der Positsion x$ und y$ geladen werden soll. Was$ macht später obs ein fester Gegenstand ist oder nicht. So der Code den ich unter "setpic" habe sieht wie folgt aus:

Private Sub setpic(FN$, W$, S$, T$)
Bild1.Picture = LoadPicture(FN$)

Dim Retval As Long
With Pic
Retval = BitBlt(.hDC, Val(S$), Val(T$), .Width, .Height, Bild1.hDC, 0, 0, SRCCOPY)
End With

If Retval = 0 Then
MsgBox "Ein Fehler ist aufgetreten.", vbCritical, "Fehler"
End If

End Sub

Mad

Die Bilder werden aber nicht angezeigt Mad

Also meine Frage: wie kann ich die Bilder endlich anzeigen (einladen) lassen. [Die Bilder sind im Unterordner Bilder]. Question

Noch mal der ganze Code Sad

:

Private Declare Function BitBlt Lib "gdi32.dll" ( _
ByVal hdcDest As Long, _
ByVal nXDest As Long, _
ByVal nYDest As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hdcSrc As Long, _
ByVal nXSrc As Long, _
ByVal nYSrc As Long, _
ByVal dwRop As Long) As Long

Private Const BLACKNESS = &H42
Private Const DSTINVERT = &H550009
Private Const MERGECOPY = &HC000CA
Private Const MERGEPAINT = &HBB0226
Private Const NOTSRCCOPY = &H330008
Private Const NOTSRCERASE = &H1100A6
Private Const PATCOPY = &HF00021
Private Const PATINVERT = &H5A0049
Private Const PATPAINT = &HFB0A09
Private Const SRCCOPY = &HCC0020
Private Const SRCAND = &H8800C6
Private Const SRCERASE = &H440328
Private Const SRCINVERT = &H660046
Private Const SRCPAINT = &HEE0086
Private Const WHITENESS = &HFF0062

' Nur zum Testen, wird dann nicht mehr benötigt
' Kopiert den Inhalt eines Bildfeldes in ein anderes,
' wobei die Farben invertiert werden
Private Sub Command1_Click()
Dim Retval As Long

xp = 50
yp = 50
With Pic
.Width = Bild1.Width
.Height = Bild1.Height
Retval = BitBlt(.hDC, xp, yp, .Width, .Height, Bild1.hDC, 0, 0, SRCCOPY)
.Width = 7000
.Height = 7000

End With

If Retval = 0 Then
MsgBox "Ein Fehler ist aufgetreten.", vbCritical, "Fehler"
End If
End Sub

Private Sub setpic(FN$, W$, S$, T$)
Bild1.Picture = LoadPicture(FN$)

Dim Retval As Long
With Pic
Retval = BitBlt(.hDC, Val(S$), Val(T$), .Width, .Height, Bild1.hDC, 0, 0, SRCCOPY)
End With

If Retval = 0 Then
MsgBox "Ein Fehler ist aufgetreten.", vbCritical, "Fehler"
End If

End Sub

Private Sub Form_Load()
Open App.Path + "\Welt.txt" For Input As #1
While Not EOF(1)
Line Input #1, a$
If Trim$(a$) = "" Then GoTo finish
pos% = InStr(a$, ";")
FileName$ = Left(a$, pos% - 1)
a$ = Mid$(a$, pos% + 1)
'_
pos% = InStr(a$, ";")
Was$ = Left(a$, pos% - 1)
a$ = Mid$(a$, pos% + 1)
'_
Mehr:

pos% = InStr(a$, ";")
x$ = Left(a$, pos% - 1)
a$ = Mid$(a$, pos% + 1)
'_
pos% = InStr(a$, ";")
If pos% <> 0 Then
Y$ = Left(a$, pos% - 1)
a$ = Mid$(a$, pos% + 1)
Else
Y$ = a$
a$ = ""
End If
Call setpic(App.Path + "\Bilder\" + FileName$, Was$, x$, Y$)

If Trim$(a$) <> "" Then GoTo Mehr

Wend
finish:
Close #1

End Sub
_________________
Nein danke, ich kaufe nichts!

christopher.g · Überflieger Anmeldedatum: 03.05.2008 Beiträge: 536

hi
geht die msgbox mit dem fehler auf
oder passiert einfach nichts?

wenn nichts passiert
lass dir vorher mal den ausgelesenen pfad zum bild ausgeben
als nächstes deine setpic funktion zeilenweise durchgehen

dann wirst sehen obs jetzt schon von anfang an nicht geladen wird
oder od es vl am bitblt liegt...
_________________