I get a weird “You have not enough memory” error off and on at the point of the LayerToRGB function; this happens whether it runs from the library or is hard-coded into the caller script. I have allotted 4GB of memory to PhotoLine and there are still many GB of RAM available, and the error sometimes happens and sometimes doesn’t, so I don’t know what is going on.
caller.vbs
Code: Alles auswählen
Option Explicit
Dim fontSize, fontColor
LoadLibrary "library.vbs"
NewImage PTRGB+PT16Bit, 900, 1500, 300, RGBColor(255, 255, 255, 255)
fontSize = (1/4)*docRes
Set fontColor = RGBColor(187, 0, 0, 255)
CreateTextLayer "Hello", "Palatino Linotype", fontSize, fontColor, _
0, docRes, docSize(0), fontSize, PACenter
LayerToRGB(8)
Emboss 135, 12, fontSize/10, 16, 5, 0
doc.ActiveLayer = doc.ActiveLayer.Previous
FillShape RGBColor(204, 204, 204, 255), _
Array((1/4)*docRes, docRes*0.9, docSize(0) - (1/4)*docRes, docRes*1.1 + fontSize)
Set doc = Nothing
Set pl = Nothing
Sub LoadLibrary(libraryFile)
Dim fso, scriptPath, scriptFile
Set fso = CreateObject("Scripting.FileSystemObject")
scriptPath = fso.GetAbsolutePathName(".")
scriptPath = fso.BuildPath(scriptPath, "Defaults")
scriptPath = fso.BuildPath(scriptPath, "Automation")
scriptPath = fso.BuildPath(scriptPath, libraryFile)
Set scriptFile = fso.OpenTextFile(scriptPath, 1)
ExecuteGlobal scriptFile.ReadAll
scriptFile.Close
End Sub
Code: Alles auswählen
Option Explicit
Dim pl, doc, docSize, docRes, docPath
'pictureType
Const PTGray = 0
Const PTRGB = 1
Const PT8Bit = 0
Const PT32Bit = 4096
Const PT16Bit = 8192
Const PTAlpha = 16384
'paragraphAlignment
Const PALeft = 0
Const PARight = 1
Const PACenter = 2
Const PAJustified = 4
Const PAJustifiedAll = 5
Const toRadians = 0.0174532925199433 '3.14159265358979/180
Set pl = CreateObject("PhotoLine.Application")
pl.Visible = True
Set doc = pl.ActiveDocument
If (Not doc Is Nothing) Then
docSize = doc.Size
docRes = doc.Resolution
docPath = Mid(doc.Path, 1, InStrRev(doc.Path, "\"))
End If
Sub NewImage(pictureType, pictureWidth, pictureHeight, pictureResolution, pictureColor)
Dim image, Base64Str
base64Str = "UGhvdG8gTGluZSBBY3Rpb25zAAAAAQAAAAABAP+bAAAADEdyb3VwQWN0aW9uAAIAAAAAAAAAAHIC" & _
"AQAAAAEAAAAEAAAAAQAAAAMAAABYAAAAAQD/mwAAAA1JQ0NOZXdBY3Rpb24AAQIAAAAAAAAABgIB" & _
"/////wAAAAEAAAAEAAIAAAAAAAIAAAAGAQAAAAAAAAAAAwAAAAEAAAAABAAAAAFA//////////8A" & _
"AAABAAAAFv+bAAAAEFNldENvbG9yUHJvZmlsZQAAAAACAAAABAAAACL/////" 'set color profile
Set doc = CreateObject("PhotoLine.Document")
doc.DocumentMode = False
Set image = CreateObject("PhotoLine.Image")
image.InitPicture pictureType, Array(pictureWidth, pictureHeight), pictureColor
doc.RootLayer.Insert image, -1
doc.Resolution = pictureResolution
doc.DoOperation "Action", "Data", base64Str, "ShowDialog", True
docSize = doc.Size
docRes = doc.Resolution
End Sub
Sub CreateTextLayer(text, fontName, fontSize, fontColor, left, top, width, height, paragraphAlignment)
'fontSize: pixels
Dim fontDict, paragraphDict, textLayer, aLayer, range
Set aLayer = doc.ActiveLayer
Set fontDict = CreateObject("PhotoLine.Dictionary")
fontDict.Add "FamilyName", fontName, "Size", fontSize
Set paragraphDict = CreateObject("PhotoLine.Dictionary")
paragraphDict.Add "Alignment", paragraphAlignment
Set textLayer = CreateObject("PhotoLine.Text")
textLayer.Text = text
range = Array(0, textLayer.TextLength)
textLayer.Origin = Array(left, top)
textLayer.Size = Array(width, height)
textLayer.SetAttribute range, "Color", fontColor
textLayer.SetAttribute range, "Font", fontDict
textLayer.SetAttribute range, "Paragraph", paragraphDict
aLayer.Parent.Insert textLayer, aLayer
doc.ActiveLayer = textLayer
End Sub
Sub LayerToRGB(bitDepth)
'converts the active layer to an RGB layer
'bitDepth 8, 16, 32
Dim hexStr
Select Case bitDepth
Case 8
bitDepth = "00"
Case 16
bitDepth = "20"
Case 32
bitDepth = "10"
End Select
hexStr = "50686f746f204c696e6520416374696f6e7300000001000000000100ff9b0000000e436f" & _
"6e76657274416374696f6e00020000000000000000120201000000010000000400000001" & _
"ffffffff000000010000000200010000000200000004" & _
bitDepth & _
"000000000000030000000400000003ffffffff"
doc.DoOperation "Action", "Data", hexStr
End Sub
Sub Emboss(direction, height, width, intensity, curve, mode)
'direction 0-360
'height 5-90
'width 0-100
'intensity 0-100
'curve 0-7 as below
'mode 0 = Unsharp, 1 = Shade
'pattern is Create From Intensity
Dim hexStr
direction = FloatToHex(direction * toRadians)
height = FloatToHex(height * toRadians)
width = ByteToHex(width)
intensity = FloatToHex(intensity)
Select Case curve
Case 0
curve = "000000000000000000000000200000000000200000000000200000000001200000000001" 'straight
Case 1
curve = "0000000000000000000000002afe0bc0ffff284121800000200000000001200000000001" 'straight raised
Case 2
curve = "00000000000000000000000029c55fc00000314ce400ffff200000000001200000000001" 'straight lowered
Case 3
curve = "000000000000200000000001200000000000200000000000200000000001000000000000" 'reversed
Case 4
curve = "00000000000020000000000129c55fc0000027598e000000200000000001000000000000" 'reversed raised
Case 5
curve = "0000000000002000000000012afe0bc0ffff2f7dbd00ffff200000000001000000000000" 'reversed lowered
Case 6
curve = "000000000000000000000000207d11800000200000000001200000000001000000000000" 'arch
Case 7
curve = "000000000000200000000001207d11800000000000000000200000000001200000000001" 'U
End Select
mode = ByteToHex(mode)
hexStr = "50686f746f204c696e6520416374696f6e7300000001000000000100ff9b0000000d456d" & _
"626f7373416374696f6e00010100000000000000120201000000010000000400000001ff" & _
"ffffff00000001000000e40001000000000000000000020000000000010000008c010000" & _
"0000050000000200" & _
mode & _
"0000000000000006" & _
direction & _
"0000000100000006" & _
height & _
"0000000200000006" & _
intensity & _
"0000000300000004000000" & _
width & _
"000000040000003e01000000000000000002000100000001000000260003" & _
curve & _
"ffffffffffffffff00000002000000360100000000000000000200030000000100000006" & _
"3243f6c0000000000002000000040000000300000003000000040000000affffffffffff" & _
"ffffffffffff"
doc.DoOperation "Action", "Data", hexStr
End Sub
Function FloatToHex(num)
Dim sign, exponent, expStr, mantissa, manStr, hexStr
If num = 0 Then
hexStr = "000000000000"
Else
sign = Sgn(num)
num = Abs(num)
exponent = Int(Log(num) / Log(2)) + 1
expStr = exponent
If expStr < 0 Then
expStr = &H10000 + expStr
End If
expStr = Hex(expStr)
expStr = String(4-Len(expStr), "0") & expStr
mantissa = Int(sign * (num / (2^exponent)) * (2^30))
manStr = Hex(mantissa)
hexStr = LCase(manStr & expStr)
End If
FloatToHex = hexStr
End Function
Function ByteToHex(num)
ByteToHex = Right("0" & Hex(num), 2)
End Function
Function LongToHex(num)
ByteToHex = Right("0000000" & Hex(num), 2)
End Function
Function PadString(str, n)
PadString = String(n - Len(str), "0") & str
End Function
Function RGBColor(rr, gg, bb, alpha)
'rr, gg, bb, alpha 0-255
Dim color
Set color = CreateObject("PhotoLine.Color")
color.Model = 1
color.Values = Array(rr/255, gg/255, bb/255, alpha/255)
Set RGBColor = color
End Function
Sub FillShape(color, ByRef pointsArray)
'fills a shape in the active layer with a color
'points array is a list of points: x0, y0, x1, y1, etc.
'2 points determine the diagonals of a rectangle; more than 2 trace out a polygon
Dim aLayer, vLayer, i
Set aLayer = doc.ActiveLayer
Set vLayer = CreateObject("PhotoLine.Vector")
vLayer.FillColor(0) = color
vLayer.LineColor(0) = Array(0, 0, 0, 0)
If UBound(pointsArray) = 3 Then
vLayer.InsertPoints 0, 0, Array(pointsArray(0), pointsArray(1), pointsArray(2), pointsArray(1), _
pointsArray(2), pointsArray(3), pointsArray(0), pointsArray(3))
Else
vLayer.InsertPoints 0, 0, Array(pointsArray(0), pointsArray(1))
For i=2 to UBound(pointsArray) Step 2
vLayer.InsertPoints -1, 1, Array(pointsArray(i), pointsArray(i+1))
Next
End If
aLayer.Parent.Insert vLayer, aLayer
doc.Merge Array(aLayer, vLayer)
End Sub