I've tried using this method to export an ole object (image) but it keeps saying run-time error 438 object doesn't support this property or method on this line:
OLEobj.SaveAs "Test" & Me.ID.Value & ".jpg"
Original Code:
Private Sub CmdExport_Click()
Set OLEobj = Me.OLEField
OLEobj.SaveAs "Test" & Me.ID.Value & ".jpg"
Set OLEobj = Nothing
End Sub
Related
I am trying to import multiple .txt files from a directory into an Access table using VBA.
I have code that currently works that imports the data and moves the files to an archive directory.
What I need to do is add the first part of the filename as field in the table, namely the date.
The file format is MMDDYYYY_LbxReport.txt (ex 02082022_LbxReport.txt)
Here is the code that I have working, and I commented out what I tried to add to fix my problem:
Private Sub Command9_Click()
On Error GoTo bImportFiles_Click_Err
Dim objFS As Object, objFolder As Object
Dim objFiles As Object, objF1 As Object
'Dim dteEntry As Variant 'added this variant for use in UPDATE cmd
Dim strFolderPath As String
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder("\\*****************\upload\SSDTestLBXa\")
Set objFiles = objFolder.files
For Each objF1 In objFiles
If Right(objF1.Name, 11) = "xReport.txt" Then 'LBX level report capture
'dteEntry = Left(objF1.Name, 8)
'dteEntry = Left(dteEntry, 2) & "/" & Mid(dteEntry, 3, 2) & "/" & Right(dteEntry, 4) 'added to reformat into standard date format
DoCmd.TransferText acImportDelim, "lbxlevelspecs", "lbxlevel", strFolderPath & objF1.Name, False
'CurrentDb.Execute "Update lbxlevel" & "Set EntryDate=" & dteEntry & "", [] 'getting syntax errors here
Name strFolderPath & objF1.Name As "\\**************\upload\SSDTestLBXa\Archive\" & objF1.Name 'Move the files to the archive folder
End If
Next
Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing
'Call Site_level
MsgBox ctr & "All volumes imported", , "Volume Import"
bImportFiles_Click_Exit:
Exit Sub
bImportFiles_Click_Err:
MsgBox Err.Number & " " & Err.Description
Resume bImportFiles_Click_Exit
End Sub
I saw a similar thread for this question, but I can't get the syntax right, and the OP's code was very different from what I have that's working so far.
Any help would be greatly appreciated!
This is how you would construct the update statement:
Public Sub doit()
Dim dteEntry As Variant
dteEntry = Left("02142024_SomeName.txt", 8)
dteEntry = Left(dteEntry, 2) & "/" & Mid(dteEntry, 3, 2) & "/" & Right(dteEntry, 4) 'added to reformat into standard date format
CurrentDb.Execute "ALTER TABLE lbxlevel ADD EntryDate DATETIME"
CurrentDb.Execute "Update lbxlevel " & "Set EntryDate='" & dteEntry & "'"
End Sub
Because it needs apace before 'SET', and quotation marks around the date.
EDIT: I added the ALTER TABLE, this tests successfully on my side.
I have a button in MS access to export an OLE word document.
Private Sub Command25_Click()
Set OLEobj = Me.POLICY_OLE
OLEobj.SaveAs Me.TRANSACTION_TYPE.Value & Me.TRANSACTION_NUMBER.Value & ".doc"
Set OLEobj = Nothing
End Sub
This is working fine but I would like to define the file path say
C:\Me.TRANSACTION_TYPE.Value & Me.TRANSACTION_NUMBER.Value & ".doc"
I'm trying to export all my tables, from my access database, to separate .csv-files. I have a loop that runs through all tables and by using TransferText I want to create a .csv-file for each table.
I am able to create a single file by writing the TransferText method.
DoCmd.TransferText acExportDelim, "ExportCsv", [Table name], filePath + "Test.csv", True
But when I'm trying to create a loop to generate a file for each table I get into trouble. (Filepath is set to desktop)
' Loops through all tables and extracts them as .csv-files
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Set db = CurrentDb
For Each tdf In db.TableDefs
' ignore system and temporary tables
If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
' Export table as CSV
'MsgBox (tdf.Name)
fileName = tdf.Name & ".csv"
DoCmd.TransferText acExportDelim, "ExportCsv", tdf.Name, filePath + fileName, True
End If
Next
Set tdf = Nothing
Set db = Nothing
Doing it like this gives me Error '3011' saying it can't find the object. Then it gives me the object name: [table name]#csv. So for some reason it changes ".csv" to "#csv".
If I remove the file extension from the file name all I get is Error 3027 saying that the object or database is read-only.
Does anyone know if there is a solution to my problem or another way to do the same thing? Or am I gonna have to go a completely different route?
EDIT:
Other tested variations
DoCmd.TransferText acExportDelim, "ExportCsv", tdf.Name, "C:/tempFile.csv", True
DoCmd.TransferText acExportDelim, "ExportCsv", tdf.Name, "C:/" & tdf.Name & ".csv", True
: Gives a "#csv" error.
DoCmd.TransferText acExportDelim, "ExportCsv", tdf.Name, "C:/tempFile", True
DoCmd.TransferText acExportDelim, "ExportCsv", tdf.Name, "C:/" & tdf.Name, True
: Gives a read only error
This is known limitation. TransferText doesn't like convoluted filenames.
So, export to a simple filename, then rename that file to its final name:
ExportFinal = "YourFinalName.csv"
ExportTemp = "FileToRename.csv"
DoCmd.TransferText acExportDelim, "ExportCsv", tdf.Name, ExportTemp, True
VBA.FileCopy ExportTemp, ExportFinal
VBA.Kill ExportTemp
So after lots of trial and error I have found a way that works for me.
With some inspiration from #Gustav I went with creating .xls files, which for some reason works. And then convert those files with a custom script to .csv-files. Then I remove the .xls files leaving only my .csv-files left.
So my loop now looks like this:
For Each tdf In db.TableDefs
' ignore system and temporary tables
If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
' Export as xls-files
fileName = tdf.Name & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, tdf.Name, filePath & env & fileName, True
' Convert xls-files to .csv and remove the xls-files.
ConvertXls2CSV (filePath & env & fileName)
VBA.Kill filePath & env & fileName
End If
Next
And here is the converting code: (Credit to: https://www.devhut.net/2012/05/14/ms-access-vba-convert-excel-xls-to-csv/)
Function ConvertXls2CSV(sXlsFile As String)
On Error Resume Next
Dim oExcel As Object
Dim oExcelWrkBk As Object
Dim bExcelOpened As Boolean 'Was Excel already open or not
'Review 'XlFileFormat Enumeration' for more formats
Const xlCSVWindows = 23 'Windows CSV Format
Const xlCSV = 6 'CSV
Const xlCSVMac = 22 'Macintosh CSV
Const xlCSVMSDOS = 24 'MSDOS CSV
Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one
Err.Clear
'On Error GoTo Error_Handler
Set oExcel = CreateObject("excel.application")
bExcelOpened = False
Else 'Excel was already running
bExcelOpened = True
End If
'On Error GoTo Error_Handler
oExcel.ScreenUpdating = False
oExcel.Visible = False 'Keep Excel hidden from the user
oExcel.Application.DisplayAlerts = False
Set oExcelWrkBk = oExcel.Workbooks.Open(sXlsFile)
'Note: you may wish to change the file format constant for another type declared
'above based on your usage/needs in the following line.
oExcelWrkBk.SaveAs Left(sXlsFile, InStrRev(sXlsFile, ".")) & "csv", xlCSVWindows, Local:=True
oExcelWrkBk.Close False
If bExcelOpened = False Then
oExcel.Quit
End If
Error_Handler_Exit:
On Error Resume Next
Set oExcelWrkBk = Nothing
Set oExcel = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: ConvertXls2CSV" & vbCrLf & _
"Error Table: " & sXlsFile & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
I have the following code:
Private Sub cmdExportTERNAME_Click()
On Error Resume Next
Me.MsgFld = "Please wait... exporting TERNAME file."
Dim expLoc As String
Dim xFile As String, myFile As String
Dim myFlag As Integer
expLoc = "I:\Investigative Names\" ' PRD
xFile = Dir(expLoc & "NAME - ForUpload.txt", vbDirectory)
myFile = "NAME-ForUpload.txt"
myFlag = StrComp(xFile, myFile)
If myFlag <> -1 Then
Kill expLoc & "NAME-ForUpload.txt"
End If
' Export text files for upload
DoCmd.TransferText acExportFixed, "SpecTERNAME", "qry_TERNAME", expLoc & "NAME-ForUpload.txt"
xFile = Dir(expLoc & "TNAME-ForUpload.txt")
myFile = "NAME-ForUpload.txt"
myFlag = StrComp(xFile, myFile)
If myFlag <> -1 Then
GoTo ContinueProcessing1
Else
MsgBox "The program was not able to export the NAME file for upload." & Chr(13) & Chr(13) & "Please notify IS Department.", vbCritical, "ERROR MESSAGE BOX"
GoTo exitRTN
End If
ContinueProcessing1:
exitRTN:
End Sub
So I have 2 more of these subroutines with different text files which work fine but this block of code doesn't find xFile, it return a empty string which causes the program to display the message box error. I can't figure out why the same code with different text file works before it reaches this code. The weird thing is it sometimes finds the correct xFile name in debug mode but not when run normally. Can someone help me figure this out?
Thanks
I wanted to copy a local file to sharepoint library using VBA by clicking an image. Right now seems like I'm unable to check for Folder & Files on SharePoint.
As every time I ran the code(by clicking an image in excel), it returns unable to find the file in SharePoint. And stops at returning the MsgBox Sorry there's no such Folder......
I tried mapping drive, it works perfectly fine, but not an options because end-user need to map the drive by themselves.
So now I'm looking to connecting to SharePoint using the link.
If I copy the SharePointLink to IE & Chrome using \, it works fine. But if I uses /, IE is unable to find the link.
UPDATE
If I uses \ after few tries, IE, will open up the file path in NetWork. Chrome will show the file path on chrome page. Why is this happening?????
The authentication is using windows authentication, so not an issue.
This is my code
Sub imgClicked()
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim FSO As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
SharePointLib = "//company.com/sites/MS/10%20Mg%20Review/"
' create new folder to store the file
copyPath = folderPath + "\copyPath\"
If Not FolderExists(copyPath) Then
FolderCreate (copyPath)
ElseIf Not FolderExists(SharePointLib) Then
MsgBox "Sorry there's no such folder. Folder Path: " & vbNewLine & vbNewLine & SharePointLib & ""
Exit Sub
End If
fileName = "hello.xlsm"
'Copy current excel file and save at the new folder created
ThisWorkbook.SaveCopyAs copyPath & fileName
MsgBox "Save Copy As: " + copyPath & filseName & vbNewLine & vbNewLine & "The file will be uploaded to this address: " + SharePointLib & fileName
' Check whether the file exist in the directory
' If exist error message
' else copy the file from copyPath then paste at the SharePoint directory
If Not Dir(SharePointLib & fileName, vbDirectory) = nbNullString Then
MsgBox "Sorry file already exist!"
Else
Call FileCopy(copyPath & fileName, SharePointLib & fileName)
MsgBox "File has being successfuly created in SharePoint!"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If Right(copyPath, 1) = "\" Then
copyPath = Left(copyPath, Len(copyPath) - 1)
End If
If FSO.FolderExists(copyPath) = False Then
MsgBox copyPath & " doesn't exist"
Exit Sub
End If
FSO.DeleteFolder copyPath
MsgBox "Folder has being deleted successfully!"
End Sub
Function for checking if folder exists
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim FSO As New FileSystemObject
If FSO.FolderExists(path) Then FolderExists = True
End Function
Function for creating Folder
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim FSO As New FileSystemObject
try:
If FSO.FolderExists(path) Then
Exit Function
Else
On Error GoTo catch
FSO.CreateFolder path
Debug.Print "FolderCreate: " & vbTab & path
Exit Function
End If
catch:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Any help and suggestions are appreciated. Let me know if more info is needed. Thanks in advance.
Ensure the WebClient service is running. You can start the WebClient service through code, or you could set the startup type to automatic.
With the WebClient service running, your folder/file tests will work as expected.
Edit: Additionally, if you map the sharepoint url to a drive letter, Windows will start the WebClient service.
Sub mapPath(str_drive as string, str_path as string)
If Not Len(str_drive) = 1 Then Exit Sub
Dim wso As Object
Set wso = CreateObject("WScript.Network")
wso.MapNetworkDrive str_drive & ":", str_path, False
End Sub