Code: (Select All)
handle& = _NewImage(800, 600, 32)
Screen handle&
Dim palentry As String * 3
Dim piccdl(800, 800) As String
Dim syf(800, 800) As String
Dim rgbpalette(256) As Long
Dim dat As String * 1
Open "c:\16color2.pcx" For Binary As #1
header$ = Space$(128)
Get #1, , header$: Cls
XRes$ = Mid$(header$, 9, 2)
XRes1$ = Left$(XRes$, 1): XRes2$ = Right$(XRes$, 1)
XRes = Asc(XRes1$) + Asc(XRes2$) * 256 + 1
YRes$ = Mid$(header$, 11, 2)
YRes1$ = Left$(YRes$, 1): YRes2$ = Right$(YRes$, 1)
YRes = Asc(YRes1$) + Asc(YRes2$) * 256 + 1
scanline$ = Mid$(header$, 67, 2)
scanline1$ = Left$(scanline$, 1): scanline2$ = Right$(scanline$, 1)
scanline = Asc(scanline1$) + Asc(scanline2$) * 256
Seek #1, &H11
For i% = 0 To 15
Get #1, , palentry$
R& = Asc(Mid$(palentry$, 1, 1))
G& = Asc(Mid$(palentry$, 2, 1))
B& = Asc(Mid$(palentry$, 3, 1))
rgbpalette&(i%) = _RGB(R&, G&, B&)
Next i%
Seek #1, &H81
c = 1: sum = 1: j = 1
Do
Get #1, , dat
Select Case Asc(dat)
Case Is < 192
syf(c, j) = Hex$(Asc(dat))
For z = 1 To 2
piccdl(c * 2 - 2 + z, j) = Mid$(syf(c, j), z, 1)
If XRes Mod 2 = 0 Then
temp = XRes
Else
temp = XRes + 1
End If
If c * 2 - 2 + z = temp Then
j = j + 1
If j = YRes Then Exit Do
c = 0
End If
Next z
c = c + 1
sum = sum + 1
Case Is > 192 And Asc(dat) <= 255
lps = Asc(dat) - 192
Seek #1, 129 + sum
Get #1, , dat
For a = 1 To lps
syf$(c, j) = Hex$(Asc(dat))
For z = 1 To 2
piccdl$(c * 2 - 2 + z, j) = Mid$(syf$(c, j), z, 1)
If XRes Mod 2 = 0 Then
temp = XRes
Else
temp = XRes + 1
End If
If c * 2 - 2 + z = temp Then
j = j + 1
If j = YRes Then Exit Do
c = 0
End If
Next z
c = c + 1
Next a
sum = sum + 2
End Select
Loop
For y = 1 To YRes
For x = 1 To XRes
a1 = HEXtoDEC&(piccdl(x, y))
PSet (x, y), rgbpalette(a1)
Next x
Next y
Close #1
Function HEXtoDEC& (hex1 As String)
Dim i As Long
Dim b As Long
hex1 = UCase$(hex1)
For i = 1 To Len(hex1)
Select Case Mid$(hex1, Len(hex1) - i + 1, 1)
Case "0": b = b + 16 ^ (i - 1) * 0
Case "1": b = b + 16 ^ (i - 1) * 1
Case "2": b = b + 16 ^ (i - 1) * 2
Case "3": b = b + 16 ^ (i - 1) * 3
Case "4": b = b + 16 ^ (i - 1) * 4
Case "5": b = b + 16 ^ (i - 1) * 5
Case "6": b = b + 16 ^ (i - 1) * 6
Case "7": b = b + 16 ^ (i - 1) * 7
Case "8": b = b + 16 ^ (i - 1) * 8
Case "9": b = b + 16 ^ (i - 1) * 9
Case "A": b = b + 16 ^ (i - 1) * 10
Case "B": b = b + 16 ^ (i - 1) * 11
Case "C": b = b + 16 ^ (i - 1) * 12
Case "D": b = b + 16 ^ (i - 1) * 13
Case "E": b = b + 16 ^ (i - 1) * 14
Case "F": b = b + 16 ^ (i - 1) * 15
End Select
Next i
HEXtoDEC& = b
End FunctionThis program is used to display pcx 16 color 1 bit planes, anyone with good suggestions is welcome to provide them