I have a PNG picture in my SQL Server, I'm successfully getting the image and saving it to file.
rs.Open "Select pic from Table", connObj, adOpenDynamic, adLockOptimistic
If rs.RecordCount > 0 Then
If Not IsNull(rs.Fields("pic").Value) Then
Set mstream = New ADODB.Stream
mstream.Type = adTypeBinary
mstream.Open
mstream.Write rs.Fields("pic").Value
mstream.SaveToFile App.Path & "\MyPhoto.jpg", adSaveCreateOverWrite
End If
End If
rs.Close
As you can see I already have my extension as .jpg but I don't think it matters, when I use the image in my vb6 application using LoadPicture() I get an Invalid Picture error. If I open the image and re-save it as jpg or bmp, LoadPicture() works.
So how can I save the picture properly as bmp/jpg?
You might find these two functions useful
Private Function LoadPictureFromBlob(baData() As Byte) As StdPicture
With CreateObject("WIA.Vector")
.BinaryData = baData
Set LoadPictureFromBlob = .Picture
End With
End Function
Private Sub SavePictureToJpg(oPic As StdPicture, sFile As String, Optional ByVal Quality = 80)
Const wiaFormatJPEG As String = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
Dim oImg As Object
SavePicture oPic, sFile
Set oImg = CreateObject("WIA.ImageFile")
oImg.LoadFile sFile
With CreateObject("WIA.ImageProcess")
.Filters.Add .FilterInfos("Convert").FilterID
.Filters.Item(1).Properties("FormatID").Value = wiaFormatJPEG
.Filters.Item(1).Properties("Quality").Value = Quality
Set oImg = .Apply(oImg)
End With
On Error Resume Next
Kill sFile
On Error GoTo 0
oImg.SaveFile sFile
End Sub
Just use Set oPic = LoadPictureFromBlob(rs.Fields("pic").Value) to read the .png and then either use built-in SavePicture oPic, App.Path & "\MyPhoto.bmp" to save to .bmp or SavePictureToJpg oPic, App.Path & "\MyPhoto.jpg" for .jpg and decide on the optional quality parameter.
Related
I am trying to accomplish a simple task of merging PDF files to one PDF. And I want the resulting PDF file to have Bookmarks to each file from the filename. And preferably i would like to have a free solution for this.
I am on a windows system and want to execute this from either command line or even better from MSSQL.
The thing is that i will create PDF files of orders from an ERP system with Crystal Reports. An stored procedure will create these PDF files. After that i want to take selected PDFs and create a new merged PDF of those and the merged PDF should have each order number (from the filename) as a bookmark. So that you easily can jump to an order number if you are searching for a specific one.
And as I said preferably free solutions, if not available I am ready to code my own merge program in for example C# or similar.
I think you would need Adobe Acrobat for this, at a bare minimum. Or, if you don't have that and you don't want to pay for it, you can convert all PDFs to TXT files, and merge all TXT files. This sounds a bit cumbersome, but actually, the easiest thing to do . . . maybe . . . is to convert all those TXT files into Excel files, and merge those. That shouldn't be hard at all. Here is a script to convert all TXT files into Excel files.
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Public Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
ChDirNet = CBool(lReturn <> 0)
End Function
Sub Get_TXT_Files()
'For Excel 2000 and higher
Dim Fnum As Long
Dim mysheet As Worksheet
Dim basebook As Workbook
Dim TxtFileNames As Variant
Dim QTable As QueryTable
Dim SaveDriveDir As String
Dim ExistFolder As Boolean
'Save the current dir
SaveDriveDir = CurDir
'You can change the start folder if you want for
'GetOpenFilename,you can use a network or local folder.
'For example ChDirNet("C:\your_path_here\")
'It now use Excel's Default File Path
ExistFolder = ChDirNet("C:\your_path_here\\Text\")
If ExistFolder = False Then
MsgBox "Error changing folder"
Exit Sub
End If
TxtFileNames = Application.GetOpenFilename _
(filefilter:="TXT Files (*.txt), *.txt", MultiSelect:=True)
If IsArray(TxtFileNames) Then
On Error GoTo CleanUp
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Add workbook with one sheet
Set basebook = Workbooks.Add(xlWBATWorksheet)
'Loop through the array with txt files
For Fnum = LBound(TxtFileNames) To UBound(TxtFileNames)
'Add a new worksheet for the name of the txt file
Set mysheet = Worksheets.Add(After:=basebook. _
Sheets(basebook.Sheets.Count))
On Error Resume Next
mysheet.Name = Right(TxtFileNames(Fnum), Len(TxtFileNames(Fnum)) - _
InStrRev(TxtFileNames(Fnum), "\", , 1))
On Error GoTo 0
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & TxtFileNames(Fnum), Destination:=Range("A1"))
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
'This example use xlDelimited
'See a example for xlFixedWidth below the macro
.TextFileParseType = xlDelimited
'Set your Delimiter to true
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
'Set the format for each column if you want (Default = General)
'For example Array(1, 9, 1) to skip the second column
.TextFileColumnDataTypes = Array(1, 9, 1)
'xlGeneralFormat General 1
'xlTextFormat Text 2
'xlMDYFormat Month-Day-Year 3
'xlDMYFormat Day-Month-Year 4
'xlYMDFormat Year-Month-Day 5
'xlMYDFormat Month-Year-Day 6
'xlDYMFormat Day-Year-Month 7
'xlYDMFormat Year-Day-Month 8
'xlSkipColumn Skip 9
' Get the data from the txt file
.Refresh BackgroundQuery:=False
End With
ActiveSheet.QueryTables(1).Delete
Next Fnum
'Delete the first sheet of basebook
On Error Resume Next
Application.DisplayAlerts = False
basebook.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error GoTo 0
CleanUp:
ChDirNet SaveDriveDir
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
The error says "The field is too small to accept the amount of data you attempted to add. Try inserting or pasting less data."
The database is supposed to pull in information from the Excel sheet that is passed through to it, and import the information into a recordset of the text field. However, the text field, somewhere down the line, has been limited to 50 characters. How can I change the maximum size of the text field? Thank you for any help
This is just part of the code, and the textfield I'm trying to make larger is "Idea_#", which is the last line of the code i posted
Sub Read_Recommendations()
On Error GoTo error_code
Dim FD As Office.FileDialog
Dim xlapp As Excel.Application
Dim xlsheet As Excel.Worksheet
Dim xlbook As Excel.Workbook
Dim db As Database
Dim rs As Recordset
Dim sql As String
Dim WP As String
Dim row As Integer
Dim File As String
Set db = CurrentDb
Set FD = Application.FileDialog(msoFileDialogOpen)
If FD.Show = True Then
File = FD.SelectedItems(1)
Set xlapp = CreateObject("Excel.Application")
Set xlbook = GetObject(File)
Set xlsheet = xlbook.Worksheets("Recommendation Approval Form")
Dim protection As Boolean
With xlsheet
'support unprotected worksheets
protection = xlsheet.ProtectContents
If protection Then xlsheet.Unprotect "veproject"
WP = .Range("WP_Number")
' Check that active WP and the WP of the uploading form is the same
' If WPs are different, awares users and prompts user whether or not to continue
Dim DifferentProject As String
If Not get_WP = WP Then
DifferentProject = MsgBox("You are uploading to the project with WP number: " & WP & " which is not the active project. Do you wish to continue?", vbYesNo)
If DifferentProject = 7 Then Exit Sub
End If
' Check that WP is correct by checking if it exists in the Record Information table
' delete the existing recomendations, we want to keep the most recent recomendations
' perhaps change this to a dialog in the future
sql = "DELETE * from tbl_recomendations WHERE WP_Number = '" & WP & "'"
db.Execute (sql)
row = 8
Set rs = db.OpenRecordset("tbl_recomendations")
Do While .Range("D" & row) <> ""
rs.AddNew
rs("WP_Number") = WP
rs("Idea_#") = (.Range("C" & row))
........
In Access, open tbl_recomendations in Design View. It sounds like the Field Size property for Idea_# is set at 50. You can change that up to 255.
If you need to store more than 255 characters in Idea_#, change its Data Type from Text to Memo.
I am trying to send some files from a folder to a fixed email address, the files need to be sent in individual emails, the file names are random.
This topic got me started:
Send individual emails to predefined set of people with all files in a folder
I altered the code a tiny bit to suit my needs, but when I run the macro it isn't sending the files. I'm sure its a simple mistake but my knowledge is limited!
This is my code:
Option Explicit
Const SOURCE_FOLDER As String = "C:\Users\Me\Desktop\Test"
Const RECIP_A As String = "me#hotmail.com"
Const EMAIL_BODY As String = "Please find attached file. Thanks and Regards, ABC"
Sub SendPDFs()
On Error GoTo ErrorHandler
Dim fileName As String
fileName = Dir(SOURCE_FOLDER)
Do While Len(fileName) > 0
Call CreateEmail(SOURCE_FOLDER & fileName)
fileName = Dir
Loop
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function CreateEmail(fileName As String)
Dim olApp As Outlook.Application
Dim msg As Outlook.MailItem
' create email
Set olApp = Outlook.Application
Set msg = olApp.CreateItem(olMailItem)
' set properties
With msg
.Body = EMAIL_BODY
.Recipients.Add (RECIP_A)
.Attachments.Add fileName
.Send
End With
End Function
Ah! The only problem with the code is
Const SOURCE_FOLDER As String = "C:\Users\Me\Desktop\Test"
Change that to
Const SOURCE_FOLDER As String = "C:\Users\Me\Desktop\Test\"
Now try it. I tried and tested it and it works.
Also ensure that you have added reference to the Outlook object library.
I'm converting a database from access to a sql backend access front end. The database has embedded pdf documents which end up getting stored as [image] data by SQL server's data import tools.
My problem is that I want the users to be able to open the pdf file by clicking the pdf icon in a report created in access.
Can this be done with VBA or is there an easier way? I'm at a total loss on how to make this happen.
Thanks for the answer!
I edited the BlobToFile function to strip out the ole header since adobe couldn't read the file (evince could and so could mac preview)
I was able to do what I wanted like this:
Private Sub PDFDocument_Click()
Call BlobToFile("C:\db\MyPDFFile.pdf", Me.PDFDocument)
If Dir("C:\db\MyPDFFile.pdf") <> "" Then
FollowHyperlink ("C:\db\MyPDFFile.pdf")
End If
End Sub
'Function: BlobToFile - Extracts the data in a binary field to a disk file.
'Parameter: strFile - Full path and filename of the destination file.
'Parameter: Field - The field containing the blob.
'Return: The length of the data extracted.
Public Function BlobToFile(strFile As String, ByRef Field As Object) As Long
On Error GoTo BlobToFileError
Dim nFileNum As Integer
Dim abytData() As Byte
Dim abytParsedData() As Byte
Dim copyOn As Boolean
Dim copyIndex As Long
BlobToFile = 0
nFileNum = FreeFile
copyOn = False
copyIndex = 0
Open strFile For Binary Access Write As nFileNum
abytData = Field
ReDim abytParsedData(UBound(abytData))
For i = LBound(abytData) To UBound(abytData) - 1
If copyOn = False Then
If Chr(abytData(i)) = "%" And Chr(abytData(i + 1)) = "P" And Chr(abytData(i + 2)) = "D" And Chr(abytData(i + 3)) = "F" Then
copyOn = True
End If
End If
If copyOn = True Then
abytParsedData(copyIndex) = abytData(i)
copyIndex = copyIndex + 1
End If
Next
Put #nFileNum, , abytParsedData
BlobToFile = LOF(nFileNum)
BlobToFileExit:
If nFileNum > 0 Then Close nFileNum
Exit Function
BlobToFileError:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, _
"Error writing file in BlobToFile"
BlobToFile = 0
Resume BlobToFileExit
End Function
If I understand what you are trying to do, you basically want Adobe Reader to open an in-memory pdf file "object". This isn't possible. You'll need to write the pdf file out to the system hard drive and then open it from there. You can somewhat achieve what you're asking by either using the computers Temp folder or else managing the files/folder yourself. For example, you could possibly cleanup your PDF file folder every time the application opens.
Here's some code to help you do what you're trying to do. This code does not handle anything to do with creating folders, generating file names, checking to see if the file already exists, etc. I'm assuming that you'll be able to handle that. My code in Command1_Click assumes that you're using SQL Server with ODBC linked tables.
I'm using FollowHyperlink here but I highly recommend that you use Allen Browne's GoHyperlink function instead to open files. You'll probably have security errors with FollowHyperlink.
Private Sub Command1_Click()
Dim r As DAO.Recordset, sSQL As String
sSQL = "SELECT ID, BlobField FROM MyTable"
Set r = CurrentDb.OpenRecordset(sSQL, dbOpenDynaset, dbSeeChanges)
If Not (r.EOF And r.BOF) Then
Call BlobToFile("C:\MyPDFFile.pdf", r("BlobField"))
If Dir("C:\MyPDFFile.pdf") <> "" Then
FollowHyperlink("C:\MyPDFFile.pdf")
End If
End If
r.Close
Set r = Nothing
End Sub
'Function: BlobToFile - Extracts the data in a binary field to a disk file.
'Parameter: strFile - Full path and filename of the destination file.
'Parameter: Field - The field containing the blob.
'Return: The length of the data extracted.
Public Function BlobToFile(strFile As String, ByRef Field As Object) As Long
On Error GoTo BlobToFileError
Dim nFileNum As Integer
Dim abytData() As Byte
BlobToFile = 0
nFileNum = FreeFile
Open strFile For Binary Access Write As nFileNum
abytData = Field
Put #nFileNum, , abytData
BlobToFile = LOF(nFileNum)
BlobToFileExit:
If nFileNum > 0 Then Close nFileNum
Exit Function
BlobToFileError:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, _
"Error writing file in BlobToFile"
BlobToFile = 0
Resume BlobToFileExit
End Function
I have a VBS file that I am trying to use to determine what folders and files are in a certain directory. I believe I have the code written correctly, but whenever I try to write out the file or current directory I get a blank text document with nothing but the root directory written out. Any advice would be greatly appreciated.
Dim NewFile
Function GetFolders (strFolderPath)
Dim objCurrentFolder, colSubfolders, objFolder, files
Set objCurrentFolder = objFSO.GetFolder(strFolderPath)
Set colSubfolders = objCurrentFolder.SubFolders
For Each objFolder In colSubfolders
NewFile.WriteLine(" - " & objFolder.Path)
Set files = folder.Files
For each folderIdx In files
NewFile.WriteLine(" - "& folderIdx.Name)
Next
Call GetFolders (objFolder.Path)
Next
End Function
Dim fso, sFolder
Set fso = CreateObject("Scripting.FileSystemObject")
sFolder = Wscript.Arguments.Item(0)
If sFolder = "" Then
Wscript.Echo "No Folder parameter was passed"
Wscript.Quit
End If
Set NewFile = fso.CreateTextFile(sFolder&"\FileList.txt", True)
NewFile.WriteLine(sFolder)
Call GetFolders(sFolder)
NewFile.Close
You haven't payed sufficient attention to your variable naming. Your script is a good example of the reason why all VBScripts should start with the line:-
Option Explicit
This would highlight all the variables that haven't been declared which in turn will point out typos and inconsistencies in variable naming. Here is how I would write it:-
Option Explicit
Dim msFolder : msFolder = Wscript.Arguments.Item(0)
If msFolder = "" Then
Wscript.Echo "No Folder parameter was passed"
Wscript.Quit
End If
Dim mfso : Set mfso = CreateObject("Scripting.FileSystemObject")
Dim moTextStream : Set moTextStream = mfso.CreateTextFile(msFolder & "\FileList.txt", True)
moTextStream.WriteLine(msFolder)
WriteFolders mfso.GetFolder(msFolder)
moTextStream.Close
Sub WriteFolders(oParentFolder)
Dim oFolder
For Each oFolder In oParentFolder.SubFolders
moTextStream.WriteLine(" - " & oFolder.Path)
Dim oFile
For Each oFile In oFolder.Files
moTextStream.WriteLine(" - " & oFile.Name)
Next
WriteFolders oFolder
Next
End Sub