' ------------------------------------------------------------------------ ' Identifying a graphic file and obtaining ' some info needed about it via custom routine/OS datatypes system ' ------------ ' Identificación de un fichero gráfico ' y devolución de la información que necesitamos sobre él. ' ------------------------------------------------------------------------ ' Arguments/Argumentos 1.51+ ' ' fich$ = Nombre del fichero (formato AmigaDOS ' como por ejemplo "SYS:Img/Ejemplo.png") ' ' Filename (AmigaDOS format like "SYS:Img/Ejemplo.png") ' ' Returned/Devuelve... ' ' O una cadena nula (problemas con el fichero) o una ' cadena con el formato " - x x " ' ' Or a null string (troubles with the file) OR an ' string with the format " - x x " ' ------------------------------------------------------------------------ ' ---------------------------------------- ' REM $include dos.bh ' REM $include datatypes.bh ' REM $include datatypes/pictureclass.bc ' REM $include datatypes/datatypesclass.bc ' ---------------------------------------- FUNCTION InfoImgFile$(fich$) SHARED en&,em$ LOCAL o&,b&,d&,tags& LOCAL a%,d%,char&,tmp$,c$ ' - Initial hypothesis: the routine fails - ' -- Hipótesis inicial: la rutina falla --- ' ----------------------------------------- InfoImgFile$ = "" ' ------------------------------------------------------------------------ ' Checking is an file is a PNG image... ' and obtaining the height, width and depth color info. ' For more info about the PNG 1.2 specification... ' http://www.w3.org/TR/REC-png.txt.gz ' "Asked" by Mr Goertz for ImageDTInfo :)... ' ------------ ' Verificando si un fichero es una imagen PNG... ' y obtención en ese caso de su altura, anchura y nº de planos de color. ' Para más información sobre el formato PNG 1.2... ' PNG (Portable Network Graphics) Specification, Version 1.2 ' http://www.w3.org/TR/REC-png.txt.gz ' "Pedido" por el Sr. Goertz para ImageDTInfo :)... ' ------------------------------------------------------------------------ ' ---- This avoid to fail the Basic string functions ----- ' - Evita que falle las funciones de cadena del Basic ;) - ' -------------------------------------------------------- c$=STRING$(25,CHR$(0)) ' -- I read from the (image) file the first 26 bytes... -- ' ---- Se leen los 26 primeros octetos del fichero... ---- ' -------------------------------------------------------- IF FEXISTS(fich$) THEN IF RIGHT$(fich$,1)=":" OR RIGHT$(fich$,1)="/" THEN em$ = liStr$(ERROR_FILE_NOT_FOUND&) ELSE OPEN fich$ FOR INPUT AS #1 IF LOF(1)>=26 THEN c$=INPUT$(26,#1) CLOSE #1 END IF ELSE em$ = liStr$(ERROR_FILE_NOT_FOUND&) END IF ' ------- I verify what the 8 first bytes are equal --------- ' --- to PNG signature and the IDHR chunk is the first. ----- ' --- Se comprueba que los 8 primeros octetos coinciden ----- ' ----- con la firma que identifica a los ficheros PNG ------ ' - y que el bloque IHDR está donde debe (en primer lugar). - ' ----------------------------------------------------------- IF LEFT$(c$,8)=CHR$(137)+"PNG"+CHR$(13)+CHR$(10)+CHR$(26)+CHR$(10)_ AND MID$(c$,13,4)="IHDR" AND ASC(RIGHT$(c$,1)) THEN tmp$="PNG -" ' ------ Obtaining the image width and height... ----- ' - Obtención de la anchura y altura de la imagen... - ' ---------------------------------------------------- FOR a%=17 TO 24 STEP 4 char&=0 FOR d%=0 TO 3 char&=char&+ASC(MID$(c$,a%+d%,1))*256^(3-d%) NEXT d% tmp$=tmp$+STR$(char&)+" x" NEXT a% ' --------------- Obtaining the color depth... --------------- ' - Obtención del número de planos (profundidad) de color... - ' ------------------------------------------------------------ a% = ASC(RIGHT$(c$,1)) IF a% = 0 OR a% = 4 THEN tmp$ = tmp$ + STR$(ASC(MID$(c$,25,1))) ELSE IF a% = 2 OR a% = 6 THEN tmp$ = tmp$ + STR$(ASC(MID$(c$,25,1))*3) ELSE tmp$ = "" END IF END IF ' ----- The function has did your work... ------ ' - I refuse the initial failure hypothesis :) - ' ------- La función ha tenido éxito... -------- ' - rechazo la hipótesis inicial de fracaso :) - ' ---------------------------------------------- InfoImgFile$ = tmp$ END IF IF tmp$ = "" THEN IF em$ = "" THEN ' IoErr() LIBRARY OPEN "dos.library",39 ' NewDTObjectA(), GetDTAttribsA(), DisposeDTObject() LIBRARY OPEN "datatypes.library",39 ' Pointer to Object struct / Puntero a estructura Object o& = NULL& ' Pointer to BitMapHeader struct / Puntero a estructura BitMapHeader b& = NULL& ' Pointer to Datatype struct / Puntero a estructura Datatype d& = NULL& ' Taglist / Lista de atributos-propiedades para funciones del S.O. DIM tags&(5) ' ---- Tags array for `NewDTObjectA()' (the function awaits ----- ' ------- a filename and will process only image files) -------- ' - Lista de atributos para `NewDTObjectA()' (la función espera - ' - el nombre de un fichero y sólo procesará ficheros gráficos) - ' --------------------------------------------------------------- TAGLIST VARPTR(tags&(0)),_ DTA_SourceType&, DTST_FILE&,_ DTA_GroupID&, GID_PICTURE&,_ TAG_DONE& ' - Creating empty structures as C style with HBasic string function - ' ---- and setting pointers to him (`Datatype' & `BitMapHeader') ----- ' --- Creando estructuras vacías al estilo del C con las funciones --- ' ----------- de cadena del HBasic y definiendo punteros ------------- ' -------------- a éstas (`Datatype' & `BitMapHeader') --------------- ' -------------------------------------------------------------------- d&=SADD(STRING$(Datatype_sizeof%,CHR$(0))) b&=SADD(STRING$(BitMapHeader_sizeof%,CHR$(0))) IF d& <> NULL& AND b& <> NULL& THEN ' ----------- As the "structs" exist I ask my object ---------- ' ----------- (the graphic file) for work with this ----------- ' --- Puesto que las estructuras han sido creadas, solicito --- ' ---- mi objeto (el fichero gráfico) para trabajar con él ---- ' ------------------------------------------------------------- o& = NewDTObjectA&(SADD(fich$+CHR$(0)),VARPTR(tags&(0))) IF o& <> NULL& THEN ' ------ As the "struct" exists I define a new taglist ------- ' --- for GetDTAttrsA& function (I want the image size and --- ' --- depth saved in BitMapHeader struct and the image type -- ' ----------- accessible via the Datatype struct). ----------- ' ----- Puesto que la estructura ha sido creada, preparo ----- ' - la nueva lista de atributos para la función GetDTAttrsA& - ' --- (necesito el tamaño de la imagen y su profundidad que -- ' ----- están guardados en la estructura BitMapHeader y ------ ' -------- el tipo de imagen accesible indirectamente -------- ' ------------ a través de la estructura Datatype). ---------- ' ------------------------------------------------------------ TAGLIST VARPTR(tags&(0)),_ PDTA_BitMapHeader&, VARPTR(b&),_ DTA_Datatype&, VARPTR(d&),_ TAG_DONE& ' ----- I ask the info needed (the function must return ---- ' ------------ the number of attribs requested) ------------ ' --------- Solicito la información que necesito ---------- ' - (la función debe devolver el nº de atributos pedidos) - ' ---------------------------------------------------------- IF GetDTAttrsA&(o&,VARPTR(tags&(0))) = 2 THEN ' ---------- Prints the info (the image type ----------- ' ------------ has four chars as maximum). -------------- ' -------- Se imprime la información (el tipo ----------- ' --- de imagen ocupa cuatro caracteres COMO MÁXIMO). --- ' ------------------------------------------------------- char& = PEEKL(d&+dtn_Header%)+dth_ID% FOR a%=0 TO 3 IF UCASE$(CHR$(PEEK(char&+a%)))<>CHR$(0) THEN tmp$=tmp$+UCASE$(CHR$(PEEK(char&+a%))) ELSE EXIT FOR END IF NEXT a% tmp$=tmp$+" -" tmp$=tmp$+STR$(PEEKW(b&+bmh_Width%)) tmp$=tmp$+" x" tmp$=tmp$+STR$(PEEKW(b&+bmh_Height%)) tmp$=tmp$+" x" tmp$=tmp$+STR$(PEEK(b&+bmh_Depth%)) ' ----- The function has did your work... ------ ' - I refuse the initial failure hypothesis :) - ' ------- La función ha tenido éxito... -------- ' - rechazo la hipótesis inicial de fracaso :) - ' ---------------------------------------------- InfoImgFile$=tmp$ ELSE ' ------------- Assign the IoErr&() result ------------ ' ---------- inmediatly or you will lost this. --------- ' --- Asigne el resultado de IoErr&() inmediatamente --- ' -------------- a una variable o lo perderá. ---------- ' ------------------------------------------------------ en& = IoErr&() em$ = "InfoDTypes$() > GetDTAttrsA&()" END IF ' ---- I've finnished with the object... I release this. ---- ' -- Hemos terminado con el objeto... así que lo liberamos. -- ' ------------------------------------------------------------ DisposeDTObject&(o&) ELSE en& = IoErr&() em$ = "InfoDTypes$() > NewDTObjectA&()" END IF ELSE em$="InfoDTypes$(): BitMapHeader/DataType"+CHR$(13) em$=em$+liStr$(ERROR_NO_MEMORY&) END IF LIBRARY CLOSE "dos.library" LIBRARY CLOSE "datatypes.library" END IF END IF END FUNCTION