Can I PrintToFIle in Access, or possibly spoof the fax driver to create Tifs? - windows

I built calculator in Access using a user form. The goal of the calculator is to document the steps taken by the user in solving a problem. It's similar to a high-school student being told to 'show their work'. I need to record a visual representation of the form. A PDF would be perfected, but I can't use PDFs.
I'm limited to file formats that are supported by our imaging server.
I know that the imaging server supports: tif, jpg, bmp and rtf. It might support other formats.
I know that these formats don't work: pdf, gif and png.
I'm an inexperienced coder (less than 6 mos), and I came up with a solution which I suspect is subpar. Occasionally, it seems to just stop working.
Essentially, I copy the form using keybd_event, and paste it into a word document, and save it as a tif file.
Is there a more conventional way of accomplishing this?
Here's my code:
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Public Sub sendToFaf()
Dim appWord As New Word.Application
Dim docWord As New Word.Document
Dim imgWord As InlineShape
Dim thisForm As Form
Dim oldPrinter As String
Dim rnd As Integer
Dim strRnd As String
Dim oldWidth As Integer
Dim oldHeight As Integer
On Error GoTo ProcessError
DoCmd.Echo (False)
DoCmd.Hourglass (True)
Set appWord = CreateObject("word.application")
Set docWord = appWord.Documents.Add
Set thisForm = Screen.ActiveForm
appWord.Visible = False
appWord.DisplayAlerts = wdAlertsNone
oldWidth = thisForm.InsideWidth
oldHeight = thisForm.InsideHeight
thisForm.InsideWidth = 10800
thisForm.InsideHeight = 11925
keybd_event VK_MENU, 0, 0, 0
DoEvents
keybd_event VK_SNAPSHOT, 0, 0, 0
DoEvents
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
DoEvents
thisForm.InsideWidth = oldWidth
thisForm.InsideHeight = oldHeight
rnd = Int((10000 - 0 + 1) * Math.rnd + 0)
strRnd = Format(rnd, "0000")
With docWord.PageSetup
.TopMargin = 0
.BottomMargin = 0
.LeftMargin = 0
.RightMargin = 0
.VerticalAlignment = wdAlignVerticalCenter
End With
docWord.Paragraphs.Alignment = wdAlignParagraphCenter
appWord.Selection.Paste
Set imgWord = docWord.InlineShapes(docWord.InlineShapes.Count)
imgWord.Width = InchesToPoints(8.5)
oldPrinter = appWord.ActivePrinter
appWord.ActivePrinter = "FAX"
appWord.PrintOut _
Background:=False, _
outputfilename:="c:\a faf\" & thisForm.Name & strRnd & ".tif", _
PrintToFile:=True
MsgBox ("File created: 'c:\a faf\" & thisForm.Name & strRnd & ".tif'")
appWord.ActivePrinter = oldPrinter
ProcessExit:
Set imgWord = Nothing
docWord.Close savechanges:=wdDoNotSaveChanges
appWord.Quit savechanges:=wdDoNotSaveChanges
Set docWord = Nothing
Set appWord = Nothing
Set thisForm = Nothing
DoCmd.Echo (True)
DoCmd.Hourglass (False)
Exit Sub
ProcessError:
MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & "Sub SendToFaf"
GoTo ProcessExit
End Sub

Related

VB6: Displaying an icon in a picture box

I'm essentially just trying to draw an icon image in a picture box.
I have the following subroutine. Input parameters verified and correct, however the icon does not display in the picture box when DrawIcon is called (this is part of a larger class).
Public Sub Draw_Icon(ByVal strDefaultIcon As String, ByVal lngIconNumber As Long, ByRef Picture_hDC As Long)
Dim lngIcon As Long
Dim lngError As Long
lngIcon = ExtractIcon(App.hInstance, strDefaultIcon, lngIconNumber)
If (lngIcon = 1 Or lngIcon = 0) Then
Call No_Icon(Picture_hDC)
Else
lngError = DrawIcon(Picture_hDC, 0, 0, lngIcon)
lngError = DestroyIcon(lngIcon)
End If
End Sub
Is there anything obvious I'm doing wrong? I've tried a number of solutions from StackOverflow and other sites to no avail.
Thank you very much for your answers. I fixed the issue with the following. I used a hidden, temporary image and picture box control to store the icon or image, respectively. Their contents are used to populate controls on the parent form. I hope that the code is readable. Thank you very much once again.
' Calling code
'
Public Function GetPictureOrIconAsImage(ByVal sFilename As String) As Picture
Dim strDefaultIcon As String
Dim lngIconNumber As Long
Dim Icon As New clsIcon
' Set error handler
On Error GoTo ErrorHandler
picTempPicture.Picture = LoadPicture("")
picTempIcon.Picture = LoadPicture("")
' Return picture if this is a picture file, otherwise attempt to return icon
If (modEasyQProcs.IsPictureFile(sFilename)) Then
picTempPicture.Picture = LoadPicture(sFilename)
Set GetPictureOrIconAsImage = picTempPicture.Picture
Else
If (Icon.GetDefaultIcon(sFilename, lngIconNumber, strDefaultIcon)) Then
Call Icon.Draw_Icon(strDefaultIcon, lngIconNumber, picTempIcon.hDC)
Else
Call Icon.No_Icon(picTempIcon.hDC)
End If
Set GetPictureOrIconAsImage = picTempIcon.Image
End If
Exit Function
ErrorHandler: ' Generic error handler
Call NonCriticalError(MODULE, Err, "GetPictureOrIconAsImage:ErrorHandler")
Err.Clear
' End of error handler scope
On Error GoTo 0
End Function
' Class Icon
'
Public Function GetDefaultIcon(ByRef FileName As String, ByRef lngIconNumber As Long, ByRef strDefaultIcon As String) As Boolean
'Parameters:
'FileName: The extension of the filename, with the "." e.g .doc
'Picture_hDC: The Handle to the device context of the Picture Box you want the icon
'to be displayed on.
'Example:
'Call GetDefaultIcon(".doc",Picture1.hDC)
Dim TempFileName As String
Dim lngError As Long
Dim lngRegKeyHandle As Long
Dim strProgramName As String
Dim lngStringLength As Long
Dim lngIcon As Long
Dim intN As Integer
GetDefaultIcon = False
TempFileName = Right(FileName, Len(FileName) - InStrRev(FileName, ".") + 1)
If (LCase(TempFileName) = ".exe") Then
strDefaultIcon = Space(260)
lngStringLength = GetSystemDirectory(strDefaultIcon, 260)
strDefaultIcon = Left(strDefaultIcon, lngStringLength) & "\SHELL32.DLL"
lngIconNumber = 2
GetDefaultIcon = True
Else
lngError = RegOpenKey(HKEY_CLASSES_ROOT, TempFileName, lngRegKeyHandle)
If (lngError = 0) Then
lngStringLength = 260
strProgramName = Space$(260)
lngError = RegQueryValueEx(lngRegKeyHandle, vbNullString, 0, 0, strProgramName, lngStringLength)
If (lngError = 0) Then
lngError = RegCloseKey(lngRegKeyHandle)
lngError = RegCloseKey(lngRegKeyHandle)
strProgramName = Left(strProgramName, lngStringLength - 1)
lngError = RegOpenKey(HKEY_CLASSES_ROOT, strProgramName & "\DefaultIcon", lngRegKeyHandle)
If (lngError = 0) Then
lngStringLength = 260
strDefaultIcon = Space$(260)
lngError = RegQueryValueEx(lngRegKeyHandle, vbNullString, 0, 0, strDefaultIcon, lngStringLength)
If (lngError) Then
lngError = RegCloseKey(lngRegKeyHandle)
Else
lngError = RegCloseKey(lngRegKeyHandle)
strDefaultIcon = Trim$(Left(strDefaultIcon, lngStringLength - 1))
intN = InStrRev(strDefaultIcon, ",")
If (intN >= 1) Then
lngIconNumber = Trim$(Right(strDefaultIcon, Len(strDefaultIcon) - intN))
strDefaultIcon = Trim$(Left(strDefaultIcon, intN - 1))
GetDefaultIcon = True
End If
End If
End If
End If
End If
End If
End Function
Public Sub Draw_Icon(ByVal strDefaultIcon As String, ByVal lngIconNumber As Long, ByRef Picture_hDC As Long)
Dim lngIcon As Long
Dim lngError As Long
lngIcon = ExtractIcon(App.hInstance, strDefaultIcon, lngIconNumber)
If (lngIcon = 1 Or lngIcon = 0) Then
Call No_Icon(Picture_hDC)
Else
lngError = DrawIcon(Picture_hDC, 0, 0, lngIcon)
If (lngError) Then lngError = DestroyIcon(lngIcon)
End If
End Sub
Public Sub No_Icon(ByRef Picture_hDC As Long)
Dim strDefaultIcon As String
Dim lngIconNumber As Long
Dim lngStringLength As Long
'No icon could be found so we use the normal windows icon
'This icon is held in shell32.dll in the system directory, Icon 0
strDefaultIcon = Space(260)
lngStringLength = GetSystemDirectory(strDefaultIcon, 260)
strDefaultIcon = Left(strDefaultIcon, lngStringLength) & "\SHELL32.DLL"
lngIconNumber = 0
Call Draw_Icon(strDefaultIcon, lngIconNumber, Picture_hDC)
End Sub

Export pictures from excel file into jpg using VBA

I have an Excel file which includes pictures in column B and I want like to export them into several files as .jpg (or any other picture file format). The name of the file should be generated from text in column A. I tried following VBA macro:
Private Sub CommandButton1_Click()
Dim oTxt As Object
For Each cell In Ark1.Range("A1:A" & Ark1.UsedRange.Rows.Count)
' you can change the sheet1 to your own choice
saveText = cell.Text
Open "H:\Webshop_Zpider\Strukturbildene\" & saveText & ".jpg" For Output As #1
Print #1, cell.Offset(0, 1).text
Close #1
Next cell
End Sub
The result is that it generates files (jpg), without any content. I assume the line Print #1, cell.Offset(0, 1).text. is wrong.
I don't know what I need to change it into, cell.Offset(0, 1).pix?
Can anybody help me? Thanks!
If i remember correctly, you need to use the "Shapes" property of your sheet.
Each Shape object has a TopLeftCell and BottomRightCell attributes that tell you the position of the image.
Here's a piece of code i used a while ago, roughly adapted to your needs. I don't remember the specifics about all those ChartObjects and whatnot, but here it is:
For Each oShape In ActiveSheet.Shapes
strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value
oShape.Select
'Picture format initialization
Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5: Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic: Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse: Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#: Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#: Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#: Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft: Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
'/Picture format initialization
Application.Selection.CopyPicture
Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
Set oChartArea = oDia.Chart
oDia.Activate
With oChartArea
.ChartArea.Select
.Paste
.Export ("H:\Webshop_Zpider\Strukturbildene\" & strImageName & ".jpg")
End With
oDia.Delete 'oChartArea.Delete
Next
This code:
Option Explicit
Sub ExportMyPicture()
Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Application.ScreenUpdating = False
On Error GoTo Finish
MyPicture = Selection.Name
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With ActiveSheet
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:="MyPic.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With
Application.ScreenUpdating = True
Exit Sub
Finish:
MsgBox "You must select a picture"
End Sub
was copied directly from here, and works beautifully for the cases I tested.
''' Set Range you want to export to the folder
Workbooks("your workbook name").Sheets("yoursheet name").Select
Dim rgExp As Range: Set rgExp = Range("A1:H31")
''' Copy range as picture onto Clipboard
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
''' Create an empty chart with exact size of range copied
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
''' Paste into chart area, export to file, delete chart.
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\ExportmyChart.jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
Dim filepath as string
Sheets("Sheet 1").ChartObjects("Chart 1").Chart.Export filepath & "Name.jpg"
Slimmed down the code to the absolute minimum if needed.
New versions of excel have made old answers obsolete. It took a long time to make this, but it does a pretty good job. Note that the maximum image size is limited and the aspect ratio is ever so slightly off, as I was not able to perfectly optimize the reshaping math. Note that I've named one of my worksheets wsTMP, you can replace it with Sheet1 or the like. Takes about 1 second to print the screenshot to target path.
Option Explicit
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Sub weGucciFam()
Dim tmp As Variant, str As String, h As Double, w As Double
Application.PrintCommunication = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If Application.StatusBar = False Then Application.StatusBar = "EVENTS DISABLED"
keybd_event vbKeyMenu, 0, 0, 0 'these do just active window
keybd_event vbKeySnapshot, 0, 0, 0
keybd_event vbKeySnapshot, 0, 2, 0
keybd_event vbKeyMenu, 0, 2, 0 'sendkeys alt+printscreen doesn't work
wsTMP.Paste
DoEvents
Const dw As Double = 1186.56
Const dh As Double = 755.28
str = "C:\Users\YOURUSERNAMEHERE\Desktop\Screenshot.jpeg"
w = wsTMP.Shapes(1).Width
h = wsTMP.Shapes(1).Height
Application.DisplayAlerts = False
Set tmp = Charts.Add
On Error Resume Next
With tmp
.PageSetup.PaperSize = xlPaper11x17
.PageSetup.TopMargin = IIf(w > dw, dh - dw * h / w, dh - h) + 28
.PageSetup.BottomMargin = 0
.PageSetup.RightMargin = IIf(h > dh, dw - dh * w / h, dw - w) + 36
.PageSetup.LeftMargin = 0
.PageSetup.HeaderMargin = 0
.PageSetup.FooterMargin = 0
.SeriesCollection(1).Delete
DoEvents
.Paste
DoEvents
.Export Filename:=str, Filtername:="jpeg"
.Delete
End With
On Error GoTo 0
Do Until wsTMP.Shapes.Count < 1
wsTMP.Shapes(1).Delete
Loop
Application.PrintCommunication = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Thanks for the ideas! I used the above ideas to make a macro to do a bulk file conversion--convert every file of one format in a folder to another format.
This code requires a sheet with cells named "FilePath" (which must end in a "\"), "StartExt" (original file extension), and "EndExt" (desired file extension). Warning: it doesn't ask for confirmation before replacing existing files with the same name and extension.
Private Sub CommandButton1_Click()
Dim path As String
Dim pathExt As String
Dim file As String
Dim oldExt As String
Dim newExt As String
Dim newFile As String
Dim shp As Picture
Dim chrt As ChartObject
Dim chrtArea As Chart
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Get settings entered by user
path = Range("FilePath")
oldExt = Range("StartExt")
pathExt = path & "*." & oldExt
newExt = Range("EndExt")
file = Dir(pathExt)
Do While Not file = "" 'cycle through all images in folder of selected format
Set shp = ActiveSheet.Pictures.Insert(path & file) 'Import image
newFile = Replace(file, "." & oldExt, "." & newExt) 'Determine new file name
Set chrt = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height) 'Create blank chart for embedding image
Set chrtArea = chrt.Chart
shp.CopyPicture 'Copy image to clipboard
With chrtArea 'Paste image to chart, then export
.ChartArea.Select
.Paste
.Export (path & newFile)
End With
chrt.Delete 'Delete chart
shp.Delete 'Delete imported image
file = Dir 'Advance to next file
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Here is another cool way to do it- using en external viewer that accepts command line switches (IrfanView in this case) :
* I based the loop on what Michal Krzych has written above.
Sub ExportPicturesToFiles()
Const saveSceenshotTo As String = "C:\temp\"
Const pictureFormat As String = ".jpg"
Dim pic As Shape
Dim sFileName As String
Dim i As Long
i = 1
For Each pic In ActiveSheet.Shapes
pic.Copy
sFileName = saveSceenshotTo & Range("A" & i).Text & pictureFormat
Call ExportPicWithIfran(sFileName)
i = i + 1
Next
End Sub
Public Sub ExportPicWithIfran(sSaveAsPath As String)
Const sIfranPath As String = "C:\Program Files\IrfanView\i_view32.exe"
Dim sRunIfran As String
sRunIfran = sIfranPath & " /clippaste /convert=" & _
sSaveAsPath & " /killmesoftly"
' Shell is no good here. If you have more than 1 pic, it will
' mess things up (pics will over run other pics, becuase Shell does
' not make vba wait for the script to finish).
' Shell sRunIfran, vbHide
' Correct way (it will now wait for the batch to finish):
call MyShell(sRunIfran )
End Sub
Edit:
Private Sub MyShell(strShell As String)
' based on:
' http://stackoverflow.com/questions/15951837/excel-vba-wait-for-shell-command-to-complete
' by Nate Hekman
Dim wsh As Object
Dim waitOnReturn As Boolean:
Dim windowStyle As VbAppWinStyle
Set wsh = VBA.CreateObject("WScript.Shell")
waitOnReturn = True
windowStyle = vbHide
wsh.Run strShell, windowStyle, waitOnReturn
End Sub

Classic ASP - Create and Return image from asp page

So I was tasked with migrating a website to a shared environment that will not allow 3rd party software installs which were used by the 3 previous developers. What I need to do is create an image from a subset of GIFs and return it from an asp page. Here is my current code:
The original page calls it as:
<p align="center"><img src="/code.asp"></p>
The code.asp page is as follows:
<%
Path = Server.MapPath("/images")
CodePath = Server.MapPath("/images/codes")
Dim test As System.Drawing.Image
Dim strWord As String
Dim nWidth = 0
Dim nHeight = 0
Dim strLetter as String
Dim imgpath As String
Dim imgpathnext As String
Dim nX As Integer
Dim binary As String
strWord = "OhYeah"
if len(strWord) = 0 then
strWord = "fjkuypd"
end if
nX = 1
strLetter = lcase(mid(strWord,nX,1))
imgpath = Path & "\letter_" & strLetter & ".gif"
for nX = 2 to len(strWord)
If(nX = 2)
strLetter = lcase(mid(strWord,nX,1))
imgpathnext = Path & "\letter_" & strLetter & ".gif"
test = MergeImages(System.Drawing.Image.FromFile(imgpath),System.Drawing.Image.FromFile(imgpathnext))
Continue For
End If
strLetter = lcase(mid(strWord,nX,1))
imgpathnext = Path & "\letter_" & strLetter & ".gif"
test = MergeImages(test,System.Drawing.Image.FromFile(imgpathnext))
next
binary = ImageConversion(test)
Response.Clear
Response.ContentType = "image/jpeg"
Response.BinaryWrite(binary)
Public Function ImageConversion(ByVal image As System.Drawing.Image) As String
If image Is Nothing Then Return ""
Dim memoryStream As System.IO.MemoryStream = New System.IO.MemoryStream
image.Save(memoryStream, System.Drawing.Imaging.ImageFormat.Gif)
Dim value As String = ""
For intCnt As Integer = 0 To memoryStream.ToArray.Length - 1
value = value & memoryStream.ToArray(intCnt) & ","
Next
Return value
End Function
Public Function MergeImages(ByVal Pic1 As System.Drawing.Image, ByVal pic2 As System.Drawing.Image) As System.Drawing.Image
Dim MergedImage As System.Drawing.Image ‘ This will be the finished merged image
Dim Wide, High As Integer
Wide = Pic1.Width + pic2.Width
If Pic1.Height >= pic2.Height Then
High = Pic1.Height
Else
High = pic2.Height
End If
Dim bm As New Bitmap(Wide, High)
Dim gr As Graphics = Graphics.FromImage(bm)
gr.DrawRectangle(Pens.Black, 0, 0, Wide - 1, High - 1)
gr.DrawImage(Pic1, 0, 0)
gr.DrawImage(pic2, Pic1.Width, 0)
MergedImage = bm
gr.Dispose()
Return MergedImage
End Function
%>
All i get back is a red X. Any help on this would be greatly appreciated.

VB6: Using Acrobat Type Library to merge PDFs in VB6

I have inherited a VB6 program that uses Crystal Reports 8.5 to run reports & then export the output to a PDF. It then uses the Adobe Acrobat 5.0 Type Library to merge the resulting PDFs into a single PDF document. Our problem is that we need to upgrade the Acrobat 5.0 Type Library but it appears that the most current version of Acrobat doesn’t provide a type library that will work with VB6. Does anyone know the most recent version of Acrobat that is supported within VB6? Also, does anyone have any suggestions of how this can be upgraded without upgrading the entire application to .Net? Thanks in advance for any help that can be provided.
I'd shell out to pdftk. Example from the man page:
Merge Two or More PDFs into a New Document
pdftk 1.pdf 2.pdf 3.pdf cat output 123.pdf
Note that if your app is distributed and non-GPL you'll need a commercial license for it, but it's only $24 at the moment.
I had this same requirement 15 years ago and created a mod in vb6 to do just that:
modMergePDF
Public Function MergePDFFiles
I recently updated the code to handle Acrobat 10.0 Type Library, so you would need to install the latest as of 8/1/2020, Acrobat DC Pro, to...
Use the below code
Use the compiled MergePDF.exe
Also, the mod adds bookmarks using the file names of the many PDF, with scrub code to
get rid of some ugly file names (you may have to expound upon that if you need to
scrub the file names to bookmark names), into the single pdf file.
Also included a function to generate batch file code:
Public Function BuildBatchFileCode
to call the MergePDF.exe passing in a command
line which consists of the Many pdf directory and the single pdf merged file directory
and file name. You can also pass in a flag to sort CaseSensitive (Any Capitalized
file names will sort above lowercase) and you can pass in another flag to maintain the .pdf extension in the bookmark name.
Find the MergePDF.exe on git up with all supporting code here:
https://github.com/Brad-Skidmore/MergePDF
Note: the error handling refers to goUtil.utErrorLog you can also find that on GitHub or you can replace it with your own error handling.
Here's the Mod code: modMergePDF
' http://www.xlsure.com 2020.07.30
' *********************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
' Merge PDF Files - modMergePDF
' *********************************************************************
Option Explicit
'PDF documents must be declared in general declaration space and not local!
Private moMainDoc As Acrobat.AcroPDDoc
Private moTempDoc As Acrobat.AcroPDDoc
Private Property Get msClassName() As String
msClassName = "modMergePDF"
End Property
Public Function MergePDFFiles(psRawPDFFilesDir As String, _
psSinglePDFOutputDir As String, _
psSinglePDFOutputName As String, _
Optional ByVal pbRemovePdfExtFromBookMark As Boolean = True, _
Optional pbCaseSensitiveSort As Boolean = False, _
Optional ByVal pbShowError As Boolean = False) As Boolean
On Error GoTo EH
Dim bFirstDoc As Boolean
Dim sRawPDFFilesDir As String
Dim sSinglePDFOutputDir As String
Dim sSinglePDFOutputName As String
Dim saryFileSort() As String
Dim sBMName As String
'Track pos of things
Dim lBMPageNo As Long
Dim lPos As Long
Dim lFile As Long
Dim lInsertPageAfter As Long
Dim lNumPages As Long
Dim lRet As Long
'Need to use Adobe internal Java Object
'in order to Add Book marks
Dim oJSO As Object 'JavaScript Object
Dim oBookMarkRoot As Object
'File I/O
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oFSO As Scripting.FileSystemObject
sRawPDFFilesDir = psRawPDFFilesDir
'ensure backslash for the 2 b merged PDF files directory
If StrComp(Right(sRawPDFFilesDir, 1), "\", vbBinaryCompare) <> 0 Then
sRawPDFFilesDir = sRawPDFFilesDir & "\"
psRawPDFFilesDir = sRawPDFFilesDir
End If
sSinglePDFOutputDir = psSinglePDFOutputDir
sSinglePDFOutputName = psSinglePDFOutputName
'ensure .pdf for the PDFOutputName (If it's CAP .PDF should be okay)
If StrComp(Right(sSinglePDFOutputName, 4), ".pdf", vbTextCompare) <> 0 Then
sSinglePDFOutputName = sSinglePDFOutputName & ".pdf"
psSinglePDFOutputName = sSinglePDFOutputName
End If
Set oFSO = New Scripting.FileSystemObject
Set oFolder = oFSO.GetFolder(sRawPDFFilesDir)
bFirstDoc = True
If oFolder.Files.Count = 0 Then
Exit Function
End If
'Because the FSO folder files collection does not allow for
'Native sorting, need to plug all the files into an array and sort that motha
ReDim saryFileSort(1 To oFolder.Files.Count)
lFile = 0
For Each oFile In oFolder.Files
lFile = lFile + 1
saryFileSort(lFile) = oFile.Name
Next
'Once they is all in der sor the array
'Sort is Case Sensitive
If pbCaseSensitiveSort Then
goUtil.utBubbleSort saryFileSort
End If
For lFile = 1 To UBound(saryFileSort, 1)
If LCase(Right(saryFileSort(lFile), 4)) = ".pdf" Then
If bFirstDoc Then
bFirstDoc = False
Set moMainDoc = CreateObject("AcroExch.PDDoc") 'New AcroPDDoc
lRet = moMainDoc.Open(sRawPDFFilesDir & saryFileSort(lFile))
Set oJSO = moMainDoc.GetJSObject
Set oBookMarkRoot = oJSO.BookMarkRoot
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
If pbRemovePdfExtFromBookMark Then
sBMName = Replace(sBMName, ".pdf", vbNullString, , , vbTextCompare)
End If
lRet = oBookMarkRoot.CreateChild(sBMName, "this.pageNum =0", lFile - 1)
Else
Set moTempDoc = CreateObject("AcroExch.PDDoc") 'New AcroPDDoc
lRet = moTempDoc.Open(sRawPDFFilesDir & saryFileSort(lFile))
'get the Book mark page number before the actual instert of new pages
lBMPageNo = moMainDoc.GetNumPages
lInsertPageAfter = lBMPageNo - 1
lNumPages = moTempDoc.GetNumPages
lRet = moMainDoc.InsertPages(lInsertPageAfter, moTempDoc, 0, lNumPages, 0)
moTempDoc.Close
If lRet = 0 Then
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
'Need to copy the errored document over to be included in the enitre document
goUtil.utCopyFile sRawPDFFilesDir & saryFileSort(lFile), sSinglePDFOutputDir & "\" & sBMName
sBMName = "PDF Insert Page Error_" & sBMName
Else
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
End If
If pbRemovePdfExtFromBookMark Then
sBMName = Replace(sBMName, ".pdf", vbNullString, , , vbTextCompare)
End If
lRet = oBookMarkRoot.CreateChild(sBMName, "this.pageNum =" & lBMPageNo, lFile - 1)
End If
End If
Next
lRet = moMainDoc.Save(1, sSinglePDFOutputDir & "\" & sSinglePDFOutputName)
moMainDoc.Close
MergePDFFiles = True
CLEAN_UP:
Set oFolder = Nothing
Set oFile = Nothing
Set oFSO = Nothing
Set oBookMarkRoot = Nothing
Set oJSO = Nothing
Set moMainDoc = Nothing
Set moTempDoc = Nothing
Exit Function
EH:
goUtil.utErrorLog Err, App.EXEName, msClassName, "Public Function MergePDFFiles", pbShowError
End Function
Public Function BuildBatchFileCode(psRawPDFFilesDir As String, _
psSinglePDFOutputDir As String, _
psSinglePDFOutputName As String, _
pbRemovePdfExtFromBookMark As Boolean, _
pbCaseSensitiveSort As Boolean) As String
On Error GoTo EH
Dim sRawPDFFilesDir As String: sRawPDFFilesDir = psRawPDFFilesDir
Dim sSinglePDFOutputDir As String: sSinglePDFOutputDir = psSinglePDFOutputDir
Dim sSinglePDFOutputName As String: sSinglePDFOutputName = psSinglePDFOutputName
Dim bRemovePdfExtFromBookMark As Boolean: bRemovePdfExtFromBookMark = pbRemovePdfExtFromBookMark
'ensure backslash for the 2 b merged PDF files directory
If StrComp(Right(sRawPDFFilesDir, 1), "\", vbBinaryCompare) <> 0 Then
sRawPDFFilesDir = sRawPDFFilesDir & "\"
psRawPDFFilesDir = sRawPDFFilesDir
End If
'ensure .pdf for the PDFOutputName (If it's CAP .PDF should be okay)
If StrComp(Right(sSinglePDFOutputName, 3), ".pdf", vbTextCompare) <> 0 Then
sSinglePDFOutputName = sSinglePDFOutputName & ".pdf"
psSinglePDFOutputName = sSinglePDFOutputName
End If
Dim sCommandLine As String
sCommandLine = "RawPDFFilesDir|" & sRawPDFFilesDir _
& "|SinglePDFOutputDir|" & sSinglePDFOutputDir _
& "|SinglePDFOutputName|" & sSinglePDFOutputName _
& "|RemovePdfExtFromBookMark|" & CStr(bRemovePdfExtFromBookMark) _
& "|CaseSensitiveSort|" & CStr(pbCaseSensitiveSort)
BuildBatchFileCode = """" & App.Path & "\" & App.EXEName & ".exe"" """ & sCommandLine
Exit Function
EH:
goUtil.utErrorLog Err, App.EXEName, msClassName, "Public Function BuildBatchFileCode"
End Function

Write text file in appending (utf-8 encoded) in VB6

I have to write a textfile in VB6. I need to do it in appending and utf-8 encoded.
I tried two solutions, one with "TextStream" and another one with "ADODB.Stream".
The first one:
Set fsoFile = fso.OpenTextFile(FileIn(fi), ForAppending, True)
fsoFile.WriteLine "<tag>kkkjòòkkkkjlòlk</tag>"
fsoFile.Close
Works good in appending but how can I write it utf-8 encoded?
The second one:
Dim ST As ADODB.Stream
Set ST = New ADODB.Stream
ST.Mode = adModeReadWrite
ST.Type = adTypeText
ST.Charset = "UTF-8"
ST.Open
ST.LoadFromFile FileIn(fi)
ST.Position = ST.Size
ST.WriteText "<tag>kkkjòòkkkkjlòlk</tag>"
ST.SaveToFile FileIn(fi)
ST.Close
Write correctly in utf-8 but I can't write the file in appending but only with "adSaveCreateOverWrite".
How can I do that? Is there another way?
Thank you very much.
You could combine binary I/O with an API call to perform the conversion to UTF-8:
Option Explicit
Private Const CP_UTF8 As Long = 65001
Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cchMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Private Function OpenAppendUTF8(ByVal FileName As String) As Integer
OpenAppendUTF8 = FreeFile(0)
Open FileName For Binary Access Write As #OpenAppendUTF8
Seek #OpenAppendUTF8, LOF(OpenAppendUTF8) + 1
End Function
Private Sub WriteUTF8( _
ByVal FNum As Integer, _
ByVal Text As String, _
Optional ByVal NL As Boolean)
Dim lngResult As Long
Dim UTF8() As Byte
If NL Then Text = Text & vbNewLine
lngResult = WideCharToMultiByte(CP_UTF8, 0, StrPtr(Text), Len(Text), _
0, 0, 0, 0)
If lngResult > 0 Then
ReDim UTF8(lngResult - 1)
WideCharToMultiByte CP_UTF8, 0, StrPtr(Text), Len(Text), _
VarPtr(UTF8(0)), lngResult, 0, 0
Put #FNum, , UTF8
End If
End Sub
Private Sub Main()
Dim F As Integer
F = OpenAppendUTF8("test.txt")
WriteUTF8 F, "Hello"
WriteUTF8 F, ChrW$(&H2026&)
WriteUTF8 F, "World", True
Close #F
MsgBox "Done"
End Sub
I prefer to save it ANSI as it does by default. Open it with a notepad and overwrite it selecting UTF8 encoding. I found it's the fastest way by far.
And I use some other code to append, for example for a database convertion:
Dim fs As Object, a
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(filename, True) 'example (myfile.xml, True)
a.writeline var1
a.writeline var2
a.Close
Actually no need for API call.
Option Explicit
Sub testAppend()
Dim fileName
fileName = "C:\Test\test.txt"
Dim f As Integer
f = FreeFile(0)
Open fileName For Binary Access Write As #f
Seek #f, LOF(f) + 1
Dim t
t = "<tag>" & ChrW(107) & ChrW(107) & ChrW(107) & ChrW(106) & ChrW(242) & ChrW(242) & ChrW(107) & ChrW(107) & ChrW(107) & ChrW(107) & ChrW(106) & ChrW(108) & ChrW(242) & ChrW(108) & ChrW(107) & "</tag>"
Put #f, , textToBinary(t, "utf-8")
Close #f
End Sub
Function textToBinary(text, charset) As Byte()
With CreateObject("ADODB.Stream")
.Open
.Type = 2 ' adTypeText
.charset = charset
.WriteText text
.Position = 0
.Type = 1 ' adTypeBinary
textToBinary = .Read
.Close
End With
End Function```

Resources