By tail, May 11 2003
This program requires tlpsdload.dll version 1.00
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
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