VB Sample for TLPSDLD.DLL

By tail, May 11 2003
This program requires tlpsdload.dll version 1.00


Form1.frm

Option Explicit

Private Sub Form_Load()

    Me.AutoRedraw = True

    ' ======= Get Dll   version =======
    Debug.Print "Dll Version  "; TlPsdLoad_GetVersion

    ' ======= Load PSD file =======
    Call LoadPsd("d:\temp\test.psd", "d:\temp\")

End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload Me
End Sub

Private Sub LoadPsd(sOpenFile As String, sDirName As String)

    Dim image_info As TLPSD_IMAGEINFO
    Dim Image() As RGBQUAD
    Dim PixCount As Long, PixelBuffSize As Long, Err As Long
    Dim rcFrame As API_RECT
    Dim sSaveFile  As String, sMsg As String
    
    PixelBuffSize = 0

    ' ======= Open PSD file =======
    ' Open a psd file by read-only and sharing mode.
    If TlPsdLoad_Open(sOpenFile, 2048&, 0&) <> 0 Then
        MsgBox "Error Code " + Str(Err)
        Exit Sub
    End If
    
    ' Retreve an image information form a psd file for getting rectangular parameter.
    ' The rectangle is used for triming image.
    image_info.nIndex = -1
    Call TlPsdLoad_GetImageInfo(image_info)
    rcFrame = image_info.rcImage
    
    ' ======= Get Image=======
    With image_info
        .nIndex = -1
        ' Retrieve image and layer informations from a psd file.
        While TlPsdLoad_GetImageInfo(image_info) = 0
            PixCount = RectWidth(.rcImage) * RectHeight(.rcImage)
            If PixCount > 0 Then ' If PixCount = 0,  there is not any layer's pixel data.
                If PixelBuffSize < PixCount - 1 Then
                    PixelBuffSize = PixCount - 1
                    ReDim Image(PixCount - 1) As RGBQUAD
                End If
                ' Retrieve image and layer data from a psd file.
                If TlPsdLoad_GetImage(.nIndex, Image(0), PixCount * 4, .rcImage) = 0 Then
                
                    Select Case .nIndex
                    Case -1 ' merged image
                        ' Show the merged image to the Form1 window.
                        Call ShowBitmap(sSaveFile, Image, .rcImage, PixCount)
                        ' Save the merged image as a bitmap file
                        sSaveFile = sDirName + "vb_image" + ".bmp"
                        Call SaveBitmap(sSaveFile, Image, .rcImage, PixCount)
                        
                    Case Else ' layer image
                        ' Trim the image
                        Call TlPsdLoad_UnderScan(Image(0), .rcImage, rcFrame)
                        Call TlPsdLoad_Minimize(Image(0), .rcImage)
                        If RectWidth(.rcImage) > 0 And RectHeight(.rcImage) > 0 Then
                            ' Save the image as a bitmap file
                            sSaveFile = sDirName + "vb_image" + Trim(Str(.nIndex)) + ".bmp"
                            Call SaveBitmap(sSaveFile, Image, .rcImage, PixCount)
                            ' Save the image as a CKiSS format file
                            sSaveFile = left(sSaveFile, Len(sSaveFile) - 4) + ".cel"
                            Call SaveCkiss(sSaveFile, Image, .rcImage, PixCount)
                        
                            sMsg = left(.szBlendMode, InStr(.szBlendMode, vbNullChar)) + vbTab + left(.szName, InStr(.szName, vbNullChar))
                            Debug.Print "Layer " + Str(.nIndex) + vbTab + "  (" + Str(RectWidth(.rcImage)) + ", " + Str(RectHeight(.rcImage)) + ") " _
                                        + vbTab + Str(.nOpacity) + vbTab + sMsg
                        End If
                    End Select
                End If
            End If
            .nIndex = .nIndex + 1
        Wend
    End With
        
    ' ======= Close the opend PSD file =======
    Call TlPsdLoad_Close

End Sub

Private Sub GetBitmapHeader(bmfh As BITMAPFILEHEADER, bmih As BITMAPINFOHEADER, ByRef Rect As API_RECT)

    Dim n As Long
    
    n = 256
    
    With bmih
        .biSize = Len(bmih)
        .biBitCount = 32
        .biHeight = RectHeight(Rect)
        .biWidth = RectWidth(Rect)
        .biSizeImage = .biWidth * .biHeight * 4
        .biPlanes = 1
    End With
    
    With bmfh
        .bfType = Asc("B") + Asc("M") * n
        .bfOffBits = bmih.biSize + Len(bmfh)
        .bfSize = .bfOffBits + bmih.biSizeImage
    End With

End Sub

Private Sub SaveBitmap(sSaveFile As String, ByRef Image() As RGBQUAD, ByRef Rect As API_RECT, PixCount As Long)

    Dim bmfh As BITMAPFILEHEADER
    Dim bmih As BITMAPINFOHEADER
    Dim i As Long, f As Integer
    
    Call GetBitmapHeader(bmfh, bmih, Rect)

    f = FreeFile
    Open sSaveFile For Binary Access Write As #f
        Put #f, , bmfh
        Put #f, , bmih
        For i = 0 To (PixCount - 1)
            Put #f, , Image(i)
        Next i
    Close #f

End Sub

Private Sub ShowBitmap(sSaveFile As String, ByRef Image() As RGBQUAD, ByRef Rect As API_RECT, PixCount As Long)

    Dim bmfh As BITMAPFILEHEADER
    Dim bmi As BITMAPINFO
    
    With bmi.bmiHeader
    Call GetBitmapHeader(bmfh, bmi.bmiHeader, Rect)
    Call StretchDIBits(Me.hdc, 0, .biHeight - 1, .biWidth, -.biHeight, 0, 0, .biWidth, .biHeight, Image(0), bmi, DIB_RGB_COLORS, SRCCOPY)
    End With

End Sub

Private Sub SaveCkiss(sSaveFile As String, ByRef Image() As RGBQUAD, ByRef Rect As API_RECT, PixCount As Long)

    Dim header As TLKISS_CELHEADER
    Dim i As Long, f As Integer
    Dim n As Long
    
    n = 256
    
    With header
        .ID = Asc("K") + (Asc("i") + (Asc("S") + Asc("S") * n) * n) * n
        .Marker = 33
        .Depth = 32
        .Pad = 0
        .Width = RectWidth(Rect)
        .Height = RectHeight(Rect)
        .OffsetX = 0
        .OffsetY = 0
        .Reserved(0) = 0
        .Reserved(1) = 0
        .Reserved(2) = 0
        .Reserved(3) = 0
    End With

    f = FreeFile
    Open sSaveFile For Binary Access Write As #f
        Put #f, , header
        For i = 0 To (PixCount - 1)
            Put #f, , Image(i)
        Next i
    Close #f

End Sub

Module1.bas

Option Explicit

Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Public Const DIB_RGB_COLORS = 0 '  color table in RGBs

Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type

Type BITMAPFILEHEADER
        bfType As Integer
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
End Type

Type BITMAPINFOHEADER '40 bytes
        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

Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type

Public Type API_RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type

Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, _
        ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, _
        ByVal wUsage As Long, ByVal dwRop As Long) As Long
'Declare Function SetRect Lib "user32" (lpRect As Rect, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'============================================================================================================
Public Const TLPSD_MAXSTR = 68

Public Type TLKISS_CELHEADER
    ID As Long
    Marker As Byte
    Depth As Byte
    Pad As Integer
    Width As Integer
    Height  As Integer
    OffsetX  As Integer
    OffsetY  As Integer
    Reserved(3) As Long
End Type

Public Type TLPSD_IMAGEINFO
    nIndex As Long         '// Zero-oder layer index.
    nGroup As Long        ' // Linkage between layers. If a layer has negative value, the layer has not any linkage.
    rcImage As API_RECT
    szName As String * TLPSD_MAXSTR
    bfVisible As Long      '// TRUE=visible, FLASE=unvisible layer
    szBlendMode As String * 8  '// Blend mode key
    nOpacity As Long       '// 0=transparent, 0XFF=opaque
    bfMaskVisible As Long  '// TRUE=visible, FLASE=unvisible layer
End Type

Declare Function TlPsdLoad_GetVersion Lib "tlpsdload.dll" () As Long
Declare Function TlPsdLoad_Open Lib "tlpsdload.dll" (ByVal sFileName As String, ByVal MaxSize As Long, ByVal Mode As Long) As Long
Declare Sub TlPsdLoad_Close Lib "tlpsdload.dll" ()
Declare Function TlPsdLoad_GetLayerCount Lib "tlpsdload.dll" () As Long
Declare Function TlPsdLoad_GetImageInfo Lib "tlpsdload.dll" (ByRef info As TLPSD_IMAGEINFO) As Long
Declare Function TlPsdLoad_GetImage Lib "tlpsdload.dll" (ByVal Index As Long, ByRef Image As Any, ByVal Size As Long, ByRef rc As API_RECT) As Long

Declare Sub TlPsdLoad_UnderScan Lib "tlpsdload.dll" (ByRef pImage As Any, ByRef rcImage As API_RECT, ByRef rcFrame As API_RECT)
Declare Sub TlPsdLoad_Minimize Lib "tlpsdload.dll" (ByRef pImage As Any, ByRef rcImage As API_RECT)

Public Function RectHeight(rc As API_RECT) As Long

    With rc
        RectHeight = .bottom - .top
    End With

End Function

Public Function RectWidth(rc As API_RECT) As Long

    With rc
        RectWidth = .right - .left
    End With

End Function