Cargar Graficos en carpeta.

sebaass

Newbie Lvl 1
Código:
Private Function CrearGrafico(Archivo As Integer, bIndex As Integer) As Integer
'12/1/3, colorkey
On Error GoTo fin
Dim ddsd As DDSURFACEDESC2, retVal As Long, ddck As DDCOLORKEY

If str(Archivo).valid = 1 Then
Call ExtractData(Archivo, DirGraficos & "Graficos.tdp", str(Archivo).where)
Else
    Exit Function
End If

ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
ddsd.lHeight = Bmx.gudtBMPInfo.bmiHeader.biHeight
ddsd.lWidth = Bmx.gudtBMPInfo.bmiHeader.biWidth

ddck.high = 0: ddck.low = 0

With mBMPDB(bIndex)
    .FileName = Archivo
    .Accesos = 0
    .Height = Bmx.gudtBMPInfo.bmiHeader.biHeight
    .Width = Bmx.gudtBMPInfo.bmiHeader.biWidth
    .Size = Bmx.gudtBMPFileHeader.bfSize
    .Cont = mContador
End With
mContador = mContador + 1

Set mSurfaceDB(bIndex) = mDDraw.CreateSurface(ddsd)
mSurfaceDB(bIndex).SetColorKey DDCKEY_SRCBLT, ddck
retVal = mSurfaceDB(bIndex).GetDC
StretchDIBits retVal, 0, 0, Bmx.gudtBMPInfo.bmiHeader.biWidth, Bmx.gudtBMPInfo.bmiHeader.biHeight, 0, 0, Bmx.gudtBMPInfo.bmiHeader.biWidth, Bmx.gudtBMPInfo.bmiHeader.biHeight, Bmx.gudtBMPData(0), Bmx.gudtBMPInfo, DIB_RGB_COLORS, SRCCOPY
mSurfaceDB(bIndex).ReleaseDC retVal

CrearGrafico = 1
mCantidadGraficos = mCantidadGraficos + 1
fin:
End Function
Como puedo hacer para que me registre los graficos desde una carpeta,ya que no hay forma de descomprimir si alguien pudiera ayudarme, busque intentar con otro modo 9.9z pero no pude hacerlo andar, no me carga la carpeta graficos ya que esta encryptado en ese archivo,

Código:
'**************************************
' Name: Convert BMP to JPG
' Description:I know what you're thinkin
'     g, just another code to turn a BMP file
'     into a JPG file. Well my code does do th
'     is, but its A LOT easier. All the other


'     submissions are complicated and use seve
    '     ral user controls/modules/class modules.
    '     This is a module with a function BMPtoJP
    '     G and THATS IT! All you need is one lone
    '     of code and your done! No other modules,
    '     or any other files are required. It uses
    '     VIC32.DLL, you can download it at http:/
    '     /education.uregina.ca/courosa/ecmp355/Hy
    '     perST/Vic32.dll. Vote if you like.
' By: Munkee
'
'
' Inputs:None
'
' Returns:None
'
'Assumes:BMPtoJPG "c:\xxxx.bmp","c:\xxxx
'     .jpg" thats all you need!
'
'Side Effects:None that I know of.
'This code is copyrighted and has limite
'     d warranties.
'Please see http://www.Planet-Source-Cod
'     e.com/xq/ASP/txtCodeId.41722/lngWId.1/qx
'     /vb/scripts/ShowCode.htm
'for details.
'**************************************


'declarations


Type imgdes
    ibuff As Long
    stx As Long
    sty As Long
    endx As Long
    endy As Long
    buffwidth As Long
    palette As Long
    colors As Long
    imgtype As Long
    bmh As Long
    hBitmap As Long
    End Type


Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
    End Type


Declare Function bmpinfo Lib "VIC32.DLL" (ByVal Fname As String, bdat As BITMAPINFOHEADER) As Long


Declare Function allocimage Lib "VIC32.DLL" (Image As imgdes, ByVal wid As Long, ByVal leng As Long, ByVal BPPixel As Long) As Long


Declare Function loadbmp Lib "VIC32.DLL" (ByVal Fname As String, desimg As imgdes) As Long


Declare Sub freeimage Lib "VIC32.DLL" (Image As imgdes)


Declare Function convert1bitto8bit Lib "VIC32.DLL" (srcimg As imgdes, desimg As imgdes) As Long


Declare Sub copyimgdes Lib "VIC32.DLL" (srcimg As imgdes, desimg As imgdes)


Declare Function savejpg Lib "VIC32.DLL" (ByVal Fname As String, srcimg As imgdes, ByVal Quality As Long) As Long
    'end declarations
    'the sub


Public Sub BMPtoJPG(Thebmp As String, Thejpg As String)
    Dim tmpimage As imgdes ' Image descriptors
    Dim tmp2image As imgdes
    Dim rcode As Long
    Dim Quality As Long
    Dim vbitcount As Long
    Dim bdat As BITMAPINFOHEADER ' Reserve space for BMP struct
    Dim bmp_fname As String
    Dim jpg_fname As String
    bmp_fname = Thebmp
    jpg_fname = Thejpg
    Quality = 15
    ' Get info on the file we're to load
    rcode = bmpinfo(bmp_fname, bdat)


    If (rcode <> NO_ERROR) Then
        MsgBox "Cannot find file", 0, "Error encountered!"
        Exit Sub
    End If
    vbitcount = bdat.biBitCount


    If (vbitcount >= 16) Then ' 16-, 24-, or 32-bit image is loaded into 24-bit buffer
        vbitcount = 24
    End If
    ' Allocate space for an image
    rcode = allocimage(tmpimage, bdat.biWidth, bdat.biHeight, vbitcount)


    If (rcode <> NO_ERROR) Then
        MsgBox "Not enough memory", 0, "Error encountered!"
        Exit Sub
    End If
    ' Load image
    rcode = loadbmp(bmp_fname, tmpimage)


    If (rcode <> NO_ERROR) Then
        freeimage tmpimage ' Free image on error
        MsgBox "Cannot load file", 0, "Error encountered!"
        Exit Sub
    End If


    If (vbitcount = 1) Then ' If we loaded a 1-bit image, convert to 8-bit grayscale
        ' because jpeg only supports 8-bit grays
        '     cale or 24-bit color images
        rcode = allocimage(tmp2image, bdat.biWidth, bdat.biHeight, 8)


        If (rcode = NO_ERROR) Then
            rcode = convert1bitto8bit(tmpimage, tmp2image)
            freeimage tmpimage ' Replace 1-bit image with grayscale image
            copyimgdes tmp2image, tmpimage
        End If
    End If
    ' Save image
    rcode = savejpg(jpg_fname, tmpimage, Quality)
    freeimage tmpimage
End Sub
Es raro porque consegui los graficos en JPG y los pase a bmp para ver si el cliente los agarraba desde los Grh tampoco existe el Graficos.ind
 

Dr. Miqueas150

The Prophet
Ex-Staff
Si tenes los graficos en .bmp ya seugn lo que decis.. y la forma facil es simplemente replaza el modulo de carga de graficos por el de fenix virgen y listo.
 
Arriba