Related
i m using asp classic. i want to rename image file while i upload image on web folder created by me. please help me out of this issue.
If there is a file in targeted folder with same name (like lokesh.jpg) what i am uploading, than new file should b automatically renamed(like lokesh(1).jpg) instead of overwriting
my code is as below:
upload.asp
<%
Class FileUploader
Public Files
Private mcolFormElem
Private Sub Class_Initialize()
Set Files = Server.CreateObject("Scripting.Dictionary")
Set mcolFormElem = Server.CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
If IsObject(Files) Then
Files.RemoveAll()
Set Files = Nothing
End If
If IsObject(mcolFormElem) Then
mcolFormElem.RemoveAll()
Set mcolFormElem = Nothing
End If
End Sub
Public Property Get Form(sIndex)
Form = ""
If mcolFormElem.Exists(LCase(sIndex)) Then Form = mcolFormElem.Item(LCase(sIndex))
End Property
Public Default Sub Upload()
Dim biData, sInputName
Dim nPosBegin, nPosEnd, nPos, vDataBounds, nDataBoundPos
Dim nPosFile, nPosBound
biData = Request.BinaryRead(Request.TotalBytes)
nPosBegin = 1
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(13)))
If (nPosEnd-nPosBegin) <= 0 Then Exit Sub
vDataBounds = MidB(biData, nPosBegin, nPosEnd-nPosBegin)
nDataBoundPos = InstrB(1, biData, vDataBounds)
Do Until nDataBoundPos = InstrB(biData, vDataBounds & CByteString("--"))
nPos = InstrB(nDataBoundPos, biData, CByteString("Content-Disposition"))
nPos = InstrB(nPos, biData, CByteString("name="))
nPosBegin = nPos + 6
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(34)))
sInputName = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
nPosFile = InstrB(nDataBoundPos, biData, CByteString("filename="))
nPosBound = InstrB(nPosEnd, biData, vDataBounds)
If nPosFile <> 0 And nPosFile < nPosBound Then
Dim oUploadFile, sFileName
Set oUploadFile = New UploadedFile
nPosBegin = nPosFile + 10
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(34)))
sFileName = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
oUploadFile.FileName = Right(sFileName, Len(sFileName)-InStrRev(sFileName, "\"))
Dim oFileExtension
If sFileName <> "" then
oFileExtension = (Right(sFileName, Len(sFileName)-InStrRev(sFileName, ".")))
If oFileExtension <> "jpg" AND oFileExtension <> "jpeg" AND oFileExtension <> "gif" AND oFileExtension <> "pdf" then
response.write("<h1>Post New File</h1><p><font color=#ff0000>An error has occurred while processing your request.<br><br>We are sorry, Extensions other than JPG, JPEG, Gif, PDF are not allowed to upload<p><b>Click <a href='javascript:history.go(-1);'>here</a> to go back and address the error.</b></font>")
response.end
Exit Sub
End if
end If
nPos = InstrB(nPosEnd, biData, CByteString("Content-Type:"))
nPosBegin = nPos + 14
nPosEnd = InstrB(nPosBegin, biData, CByteString(Chr(13)))
oUploadFile.ContentType = CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
nPosBegin = nPosEnd+4
nPosEnd = InstrB(nPosBegin, biData, vDataBounds) - 2
oUploadFile.FileData = MidB(biData, nPosBegin, nPosEnd-nPosBegin)
If sfileName <> "" then
If oUploadFile.FileSize > 10000000 Then
response.write("<h1>Post New Image</h1><p><font color=#ff0000>An error has occurred while processing your request.<br><br>We are sorry, Upload file containing 10000000(10mb) bytes only.<p><b>Click <a href='javascript:window:history.go(-1);'>here</a> to go back and address the error.</b></font>")
response.end
Exit Sub
End if
End if
If oUploadFile.FileSize > 0 Then Files.Add LCase(sInputName), oUploadFile
Else
nPos = InstrB(nPos, biData, CByteString(Chr(13)))
nPosBegin = nPos + 4
nPosEnd = InstrB(nPosBegin, biData, vDataBounds) - 2
If Not mcolFormElem.Exists(LCase(sInputName)) Then mcolFormElem.Add LCase(sInputName), CWideString(MidB(biData, nPosBegin, nPosEnd-nPosBegin))
End If
nDataBoundPos = InstrB(nDataBoundPos + LenB(vDataBounds), biData, vDataBounds)
Loop
End Sub
'String to byte string conversion
Private Function CByteString(sString)
Dim nIndex
For nIndex = 1 to Len(sString)
CByteString = CByteString & ChrB(AscB(Mid(sString,nIndex,1)))
Next
End Function
'Byte string to string conversion
Private Function CWideString(bsString)
Dim nIndex
CWideString =""
For nIndex = 1 to LenB(bsString)
CWideString = CWideString & Chr(AscB(MidB(bsString,nIndex,1)))
Next
End Function
End Class
Class UploadedFile
Public ContentType
Public FileName
Public FileData
Public Property Get FileSize()
FileSize = LenB(FileData)
End Property
Public Sub SaveToDisk(sPath)
Dim oFS, oFile
Dim nIndex
If sPath = "" Or FileName = "" Then Exit Sub
If Mid(sPath, Len(sPath)) <> "\" Then sPath = sPath & "\"
Set oFS = Server.CreateObject("Scripting.FileSystemObject")
If Not oFS.FolderExists(sPath) Then Exit Sub
Set oFile = oFS.CreateTextFile(sPath & FileName, True)
For nIndex = 1 to LenB(FileData)
oFile.Write Chr(AscB(MidB(FileData,nIndex,1)))
Next
oFile.Close
End Sub
Public Sub SaveToDatabase(ByRef oField)
If LenB(FileData) = 0 Then Exit Sub
If IsObject(oField) Then
oField.AppendChunk FileData
End If
End Sub
End Class
%>
submit.asp
<!-- #include file="upload.asp" -->
<%
response.buffer = true
Dim Uploader, File, i, j
Set Uploader = New FileUploader
Uploader.Upload()
Dim brandnm, filename
brandnm = Uploader.form("brandname")
Dim objRSa, objCmda, stra
Set objCmda = server.CreateObject("adodb.connection")
Set Objrsa = Server.CreateObject("ADODB.Recordset")
objCmda.open MM_connDUdirectory_STRING
stra = "SELECT * FROM brand"
Objrsa.Open stra,objCmda,1,2
if Uploader.Files.count <> 0 then
File = Uploader.Files.Items()
File(0).SavetoDisk Server.MapPath("upload/brands") 'Folder path where image will save
filename = File(0).Filename
else
filename = ""
End if
Objrsa.addnew
Objrsa.fields("brand_name") = brandnm
Objrsa.fields("brand_createddt") = now()
if filename <>"" then Objrsa.fields("brand_picpath") = filename
For Each File In Uploader.Files.Items
Objrsa("brand_ctype") = File.ContentType
next
Objrsa.Update
Objrsa.Close
Set Objrsa = Nothing
set objCmda = Nothing
%>
Please help me out of this issue.
If you want to rename it to follow a known pattern as in your example ("filename(number).ext"), you must to use a pseudo-code like this:
let counter = 1
let original = file(0).Filename
let current = file(0).Filename
while(current file exists)
current = original-without-extension + (counter) + original-extension
counter = counter + 1
end
However, I think that would be better to store the user provided filename into your database and choose a random-like filename to store the actual file into the filesystem.
let current = userLogin + (currentTime as yyyyMMddHHmmss) + ".uploaded"
By using a bogus file extension you make your application way more secure, as your file will not be interpretable/executable -- imagine a malicious user uploading an .ASP file and executing it.
If this break the image MIME type, you should consider creating another .ASP page read the database to discover the appropriate MIME type based on the user provided file extension, write that content-type and the binary file content.
TL;DR: don't use the user provided file name, create a new one. This will avoid server hacking.
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
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
I've recently changed from a PC to a Mac. I run a lot of a macros and 99% of them are running fine, but I have one that doesn't work on a Mac.
It runs a set of other macros across all workbooks in a file. To do this it uses strings like this:
Function BrowseFolder(Title As String, _
Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = _
msoFileDialogViewList) As String
When I try to run this on the Mac it comes back with an error:
"compile error: variable not defined"
I wonder if anyone could help me with porting this macro over to run on Mac. It was built on Excel 2007 Windows and I'm trying to run it on Excel 2011 Mac.
Option Explicit
Function GetFolder(Optional strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
If Not IsEmpty(strPath) Then
.InitialFileName = strPath
End If
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Private Sub test()
Dim v As Variant
'V = GetFolder()
v = BrowseFolder("Select folder")
End Sub
Function BrowseFolder(Title As String, _
Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = _
msoFileDialogViewList) As String
Dim v As Variant
Dim InitFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
If Len(InitialFolder) > 0 Then
If Dir(InitialFolder, vbDirectory) <> vbNullString Then
InitFolder = InitialFolder
If Right(InitFolder, 1) <> "\" Then
InitFolder = InitFolder & "\"
End If
.InitialFileName = InitFolder
End If
End If
.Show
On Error Resume Next
Err.Clear
v = .SelectedItems(1)
If Err.Number <> 0 Then
v = vbNullString
End If
End With
BrowseFolder = CStr(v)
End Function
msoFileDialogViewList refers to a specific view of the Windows standard file dialog. The Mac standard file dialog doesn't have equivalent modes; my guess is that the InitialView parameter either doesn't exist or is ignored on the Mac platform.
I'd advise either removing the parameter entirely or using the equivalent integer value (1) instead of the symbolic name.
I'm working on an Outlook add-in that requires the Office specific FileDialog to interoperate with a Sharepoint site; the common file dialog doesn't have the interoperability. I know that both Word and Excel have a get_fileDialog method under Globals.ThisAddIn.Application.Application, but Outlook doesn't seem to. How do I launch an Outlook FileDialog? Is it even possible?
Microsoft Common Dialog
If you have COMDLG32.OCX ("Common Dialog ActiveX Control") installed, then you can use this - it's explained here, with an example. (Scroll down just past the screenshot entitled "FIGURE 2: Don't try to select more than one file in Word! ").
It appears that Outlook's Application object does not offer FileDialog. But a simple workaround, if you are willing to have an Excel reference, is:
Dim fd As FileDialog
Set fd = Excel.Application.FileDialog(msoFileDialogFolderPicker)
Dim folder As Variant
If fd.Show = -1 Then
For Each folder In fd.SelectedItems
Debug.Print "Folder:" & folder & "."
Next
End If
'Add a "Module". Then add the declarations like this to it.
Option Explicit
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function MyOpenFiledialog() As String
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
'Set the parent window
OFName.hwndOwner = Application.hWnd
'Set the application's instance
OFName.hInstance = Application.hInstance
'Select a filter
OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'create a buffer for the file
OFName.lpstrFile = Space$(254)
'set the maximum length of a returned file
OFName.nMaxFile = 255
'Create a buffer for the file title
OFName.lpstrFileTitle = Space$(254)
'Set the maximum length of a returned file title
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = "C:\"
'Set the title
OFName.lpstrTitle = "Open File - VB Forums.com"
'No flags
OFName.flags = 0
'Show the 'Open File'-dialog
If GetOpenFileName(OFName) Then
MsgBox "File to Open: " + Trim$(OFName.lpstrFile)
MyOpenFiledialog = Trim$(OFName.lpstrFile)
Else
MsgBox "Cancel was pressed"
MyOpenFiledialog = vbNullString
End If
End Sub 'Usage:
Private Sub Command1_Click()
Text1.Text = MyOpenFiledialog
End Sub
Public Sub TestFileDialog()
Dim otherObject As Excel.Application
Dim fdFolder As office.FileDialog
Set otherObject = New Excel.Application
otherObject.Visible = False
Set fdFolder = otherObject.Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.Show
Debug.Print fdFolder.SelectedItems(1)
otherObject.Quit
Set otherObject = Nothing
End Sub
Private Sub multiEML2MSG()
Const PR_ICON_INDEX = &H10800003
Dim objPost As Outlook.PostItem
Dim objSafePost As Redemption.SafePostItem
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Set objNS = Outlook.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objPost = objInbox.Items.Add(OlItemType.olPostItem)
Set objSafePost = New Redemption.SafePostItem
Dim xlObj As Excel.Application
Dim fd As Office.FileDialog
Set xlObj = New Excel.Application
Set fd = xlObj.Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select your PST File"
.ButtonName = "Ok"
.Show
If fd.SelectedItems.Count <> 0 Then
xDirect$ = fd.SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
licznik = 1
Do While xFname$ <> ""
XPathEML = xDirect$ & xFname$
XPathMSG = Replace(XPathEML, ".eml", ".msg", , , vbTextCompare)
Debug.Print XPath, Replace(XPath, ".eml", ".msg", , , vbTextCompare)
objPost.Save
objSafePost.Item = objPost
objSafePost.Import XPathEML, Redemption.RedemptionSaveAsType.olRFC822
objSafePost.MessageClass = "IPM.Note"
objSafePost.Fields(PR_ICON_INDEX) = none
objSafePost.SaveAs XPathMSG, Outlook.OlSaveAsType.olMSG
xFname$ = Dir
licznik = licznik + 1
Loop
End If
End With
xlObj.Quit
Set xlObj = Nothing
Set objSafePost = Nothing
Set objPost = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub