Been using code below for years. It creates new folder, and names it to next work-day's date + adds another folder within this, named "VO".
Code got two "fPath"-lines. The one at pause is the original one. With this one I can move my files around, and code will still create new folder, based on location of ThisWorkbook.
However, with OneDrive, original "fPath"-line ends in "Run-time error 52: Bad file name or number", marking line .CreateFolder (EndDir1).
Why doesn't this code work in OneDrive? When I change "fPath"-line into complete address, it works just fine.
Sub NewFolderNextWorkDay()
Dim FSO As Object
Dim fsoObj As Object
Dim NeArbDg As Double
NeArbDg = Application.WorkDay(Date, 1)
Dim Dato As String
Dim fPath As String
Dim EndDir1, EndDir2 As String
Dato = Format(NeArbDg, "yyyy-mm-dd")
'fPath = ThisWorkbook.Path & "\..\" '(old code, worked fine until OneDrive came along)
fPath = "C:\Users\MyId\OneDrive - MyJob\Mine dokumenter\PROD\TEST\2022\" '(new code, works ok with OneDrive)
EndDir1 = (fPath & Dato & "\")
EndDir2 = (fPath & Dato & "\VO")
Set fsoObj = CreateObject("Scripting.FileSystemObject")
With fsoObj
If Not .FolderExists(EndDir1) Then
.CreateFolder (EndDir1)
End If
If Not .FolderExists(EndDir2) Then
.CreateFolder (EndDir2)
End If
End With
End Sub
This function from the linked post (https://stackoverflow.com/a/67582367/478884) seems to work for me. I did need to make a change to fix an issue when strCID has no content. See lines marked ####
Function GetLocalFile(wb As Workbook) As String
' Set default return
GetLocalFile = wb.FullName
Const HKEY_CURRENT_USER = &H80000001
Dim strValue As String
Dim objReg As Object: Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Dim strRegPath As String: strRegPath = "Software\SyncEngines\Providers\OneDrive\"
Dim arrSubKeys() As Variant
objReg.EnumKey HKEY_CURRENT_USER, strRegPath, arrSubKeys
Dim varKey As Variant
For Each varKey In arrSubKeys
' check if this key has a value named "UrlNamespace", and save the value to strValue
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "UrlNamespace", strValue
' If the namespace is in FullName, then we know we have a URL and need to get the path on disk
If InStr(wb.FullName, strValue) > 0 Then
Dim strTemp As String
Dim strCID As String
Dim strMountpoint As String
' Get the mount point for OneDrive
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "MountPoint", strMountpoint
' Get the CID
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "CID", strCID
' strip off the namespace and CID
If Len(strCID) > 0 Then strValue = strValue & "/" & strCID '#####
strTemp = Right(wb.FullName, Len(wb.FullName) - Len(strValue)) '#####
' replace all forward slashes with backslashes
GetLocalFile = strMountpoint & "\" & Replace(strTemp, "/", "\")
Exit Function
End If
Next
End Function
Change https://my.... to C:\users\...:
Sub Sample()
GetLocalFile = Split(ThisWorkbook.Path, "/Documents")(2)
GetLocalFile = Replace(GetLocalFile, "/", "\")
MyPath = Environ("onedrive") & "\documents" & GetLocalFile
MkDir (MyPath & "\New")
End Sub
Related
Sorry to bother you, but I'm at an impasse :(
To summarize my situation, I need to recover an entire sheet of all files in a folder. My macro goes through them one by one and picks it up.
The problem is that I can have "xlsm" files that show me a warning pop up because there are macros and "trust" etc... Pop up that I can't remove because it doesn't cannot be disabled.
(I also can't change my excel options for X reasons because I'm not the only one using the macro).
I would therefore like to convert my "xlsm" to "xlsx" without having to open it to avoid the pop up. A simple change of extension damages the file (obvious)
Do you have a solution for saveas without opening the file or opening it without having the pop-up?
Thanks in advance !
Make the macro to open the files as read-only, so the pop up doesn't apear regarding trust.
Set my_wb = Workbooks.Open(Filename:=file_path, ReadOnly:=True)
And make the make macro to save the files as xlsx
Application.DisplayAlerts = False
my_wb.SaveAs fileName:="myFileName.xlsx"
As I said in my above comment, adding the folder where the workbooks in discussion exist in Excel Trusted Locations can be a solution, to avoid warnings related to trustful workbooks. Adding the folder path, in code, can be done in the next way:
Private Function CreatePathInTrLoc(ByVal sPath As String, ByVal sDescription As String, Optional boolReplace As Boolean) As Boolean
Const HKEY_CURRENT_USER = &H80000001, sAppExe As String = "excel.exe", sApp As String = "Excel"
Dim oRegistry As Object, sAppVer As String, sParentKey As String, bAlreadyExists As Boolean
Dim arrChildKeys As Variant, sChildKey As Variant, sValue As String, sNewKey As String
Dim iLocCounter As Long, strReplace As String, sExtPath As String
Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
sAppVer = GetAppVersion(sAppExe)
sAppVer = left(sAppVer, InStr(sAppVer, ".") - 1) & "." & Mid(sAppVer, InStr(sAppVer, ".") + 1, 1)
sParentKey = "Software\Microsoft\Office\" & sAppVer & "\" & sApp & "\Security\Trusted Locations"
iLocCounter = 0
oRegistry.EnumKey HKEY_CURRENT_USER, sParentKey, arrChildKeys
For Each sChildKey In arrChildKeys
oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Description", sValue
If sValue = sDescription Then
If boolReplace Then
oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Path", sExtPath
If sExtPath <> sPath Then
oRegistry.DeleteKey HKEY_CURRENT_USER, sParentKey & "\" & sChildKey
strReplace = sChildKey
GoTo OverDeleteKey
Else
bAlreadyExists = True
CreatePathInTrLoc = True
End If
Else
bAlreadyExists = True
CreatePathInTrLoc = True
End If
End If
If CInt(Mid(sChildKey, 9)) > iLocCounter Then
iLocCounter = CInt(Mid(sChildKey, 9))
End If
Next
OverDeleteKey:
If Not bAlreadyExists Then
sNewKey = sParentKey & IIf(strReplace <> "", "\" & strReplace, "\Location" & CStr(iLocCounter + 1))
oRegistry.CreateKey HKEY_CURRENT_USER, sNewKey
oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Path", sPath
oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Description", sDescription
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sNewKey, "AllowSubFolders", 1
CreatePathInTrLoc = True
Debug.Print "Path """ & sPath & """ added in Trusted Locations."
Else
Debug.Print "Path """ & sPath & """ already exists..."
End If
End Function
Private Function GetAppVersion(sAppExe As String) As String 'extract application version
Const HKEY_LOCAL_MACHINE = &H80000002
Dim oRegistry As Object, oFSO As Object, sKey As String, sValue As String
Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//./root/default:StdRegProv")
Set oFSO = CreateObject("Scripting.FileSystemObject")
sKey = "Software\Microsoft\Windows\CurrentVersion\App Paths"
oRegistry.GetStringValue HKEY_LOCAL_MACHINE, sKey & "\" & sAppExe, "", sValue
GetAppVersion = oFSO.GetFileVersion(sValue)
Set oFSO = Nothing: Set oRegistry = Nothing
End Function
The above solution can be tested as:
Sub testCreatePathInTrLoc()
Debug.Print CreatePathInTrLoc("C:\temp", "TestLocation")
End Sub
The called Sub needs as parameters: folder path to be added, Trusted location name/description and a Boolean Optional parameter if you want replacing an existing trusted location.
I'm trying to open a folder where I don't know the full path.
For example, the parent folder dir is "D:\Documents" and the folder I want to open is called "22.111 - PROJECT_NAME", where I know the code, but don't know the name. I've tried with "*", but no luck.
Sub OpenFolder()
On Error GoTo Err_cmdExplore_Click
Dim Code As String
Code = Range("A1").Value
GoToFolder = "C:\Windows\explorer.exe D:\Documents\" & Code & "*"
Call Shell(GoToFolder, 1)
Exit_cmdExplore_Click:
Exit Sub
Err_cmdExplore_Click:
MsgBox ("Pasta não encontrada")
Resume Exit_cmdExplore_Click
End Sub
Found the answer on another forum (mrexcel.com), leaving it below for anyone that faces the same problem:
Public Sub Find_and_Open_Folder()
Dim Code As String
Dim targetFolder As String
Code = Range("A1").Value
targetFolder = Dir("D:\Documents\" & Code & "*", vbDirectory)
If targetFolder <> vbNullString Then
Shell "explorer.exe """ & "D:\Documents\" & targetFolder & """", vbNormalFocus
Else
MsgBox "Folder matching D:\Documents\" & Code & "* not found"
End If
End Sub
With the parent folder available and the knowledge that the subfolder starts with 22.111, you could loop through all subfolders in the parent folder, and list all the potential matches using InStr. Example of how you might do this:
Sub CodeSnippet()
Dim myFolderName As String
'GetFolders returns array
Dim folderNamesWithPattern As Variant
'searching for "22.111" at 1st pos in string of potential subfolder
folderNamesWithPattern = GetFolders("D:\Documents", "22.111", 1)
If UBound(folderNamesWithPattern) > 0 Then
'more than one folder that meets your pattern:
'decide what to do
Else
'only one entry in array, this is your folder or if "" then ( no such folder | parent folder does not exist )
myFolderName = folderNamesWithPattern(0)
End If
End Sub
Function GetFolders(strDirectory As String, pattern As String, position As Long) As Variant
Dim objFSO As Object
Dim objFolders As Object
Dim objFolder As Object
'create filesystem obj
Set objFSO = CreateObject("Scripting.FileSystemObject")
'create folder obj and access subfolders property
On Error GoTo errorHandler
Set objFolders = objFSO.GetFolder(strDirectory).SubFolders
'dim array for matches
Dim arrFolderNames() As Variant
arrFolderNames = Array()
'loop through all folders
For Each objFolder In objFolders
'InStr() returns 0 if not found | index 1st char in string if found
If InStr(objFolder.Name, pattern) = 1 Then
'add match to array
ReDim Preserve arrFolderNames(UBound(arrFolderNames) + 1)
arrFolderNames(UBound(arrFolderNames)) = objFolder.Name
End If
Next objFolder
'assign array for return
GetFolders = arrFolderNames
errorHandler:
If objFolders Is Nothing Then
'parent folder does not exist
GetFolders = Array("")
ElseIf UBound(arrFolderNames) = -1 Then
'we never found a subfolder that starts with pattern
GetFolders = Array("")
End If
End Function
If you want to use RegEx, you might want to look at How do i use regex using instr in VBA.
Explore a Folder Using Workbook.FollowHyperlink
Workbook.FollowHyperlink method (MSDocs)
A Known Worksheet in the Workbook Containing This Code (ThisWorkbook)
Sub ExploreFolder()
Const iFolderPath As String = "D:\Documents\"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim Code As String: Code = CStr(ws.Range("A1").Value)
Dim dFolderPattern As String: dFolderPattern = iFolderPath & Code & "*"
Dim dFolder As String: dFolder = Dir(dFolderPattern, vbDirectory)
If Len(dFolder) > 0 Then
wb.FollowHyperlink iFolderPath & dFolder
Else
MsgBox "A folder matching the pattern '" & dFolderPattern _
& "' was not found.", vbCritical, "Explore Folder"
End If
End Sub
ActiveSheet (not recommended)
Sub ExploreFolderActiveSheet()
Const iFolderPath As String = "D:\Documents\"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim Code As String: Code = CStr(ws.Range("A1").Value)
Dim dFolderPattern As String: dFolderPattern = iFolderPath & Code & "*"
Dim dFolder As String: dFolder = Dir(dFolderPattern, vbDirectory)
If Len(dFolder) > 0 Then
ws.Parent.FollowHyperlink iFolderPath & dFolder
Else
MsgBox "A folder matching the pattern '" & dFolderPattern _
& "' was not found.", vbCritical, "Explore Folder"
End If
End Sub
I want to copy specific file type(*.SLDDRW) from source to destination,in destination path we have lots of folders and sub-folders .in below code i am trying to walk on any sub folders but unfortunately it didn't work and didn't walk all sub-folders S.O can help me?
Sub copy_specific_files_in_folder()
Dim FSO As Object
Dim sourcePath As String
Dim destinationPath As String
Dim fileExtn As String
sourcePath = "C:\Users\6\"
destinationPath = "C:\Users\"
fileExtn = "*.SLDDRW"
If Right (sourcePath, 1) <> "\" Then
sourcePath = sourcePath & "\"
End If
Set FSO = CreateObject ("scripting.filesystemobject")
If FSO.FolderExists(sourcepath) = False Then
MsgBox sourcePath & " does not exist"
Exit Sub
End If
FSO.CopyFile Source:=sourcePath & fileExtn, Destination :=destinationPath
copy_files_from_subfolders
MsgBox "Your files have been copied from the sub-folders of " & sourcePath
End sub
sub copy_files_from_subfolders()
Dim FSO AS Object , fld As Object
Dim fsoFile As Object
Dim fsoFol As Object
sourcePath = "C:\Users\6\"
targetPath = "C:\Users\"
If Right (sourcePath , 1) <> "\" then sourcePath = sourcePath & "\"
Set FSO = createObject("Scripting.FileSystemObject")
Set fld = FSO.getFolder(sourcePath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(sourcePath).SubFolders
For Each fsoFile In fsoFol.Files
If Right (fsoFile, 6) = "sldprt" Then
fsoFile.Copy targetPath
End If
Next
Next
End If
Here's a function that will recursively search a folder and all subfolders for a specific extension and then copy found files to a specified destination:
Sub SearchFoldersAndCopy(ByVal arg_sFolderPath As String, _
ByVal arg_sDestinationFolder As String, _
ByVal arg_sExtension As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oSubFolder As Object
Dim sTest As String
'Test if FolderPath exists
sTest = Dir(arg_sFolderPath, vbDirectory)
If Len(sTest) = 0 Then
MsgBox "Specified folder [" & arg_sFolderPath & "] doesn't exist. Please check spelling or create the directory."
Exit Sub
End If
'Test if Destination exists
sTest = Dir(arg_sDestinationFolder, vbDirectory)
If Len(sTest) = 0 Then
MsgBox "Specified destination [" & arg_sDestinationFolder & "] doesn't exist. Please check spelling or create the directory."
Exit Sub
End If
'FolderPath and Destination both exist, proceed with search and copy
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(arg_sFolderPath)
'Test if any files with the Extension exist in directory and copy if one or more found
sTest = Dir(oFolder.Path & Application.PathSeparator & "*." & arg_sExtension)
If Len(sTest) > 0 Then oFSO.copyfile oFolder.Path & Application.PathSeparator & "*." & arg_sExtension, arg_sDestinationFolder
'Recursively search subfolders
For Each oSubFolder In oFolder.SubFolders
SearchFoldersAndCopy oSubFolder.Path, arg_sDestinationFolder, arg_sExtension
Next oSubFolder
End Sub
Here's an example of how to call it:
Sub tgr()
Dim sStartFolder As String
Dim sDestination As String
Dim sExtension As String
sStartFolder = "C:\Test"
sDestination = "C:\Output\" '<-- The ending \ may be required on some systems
sExtension = "SLDDRW"
SearchFoldersAndCopy sStartFolder, sDestination, sExtension
End Sub
I have an Excel file with hundreds of Customer names and several article numbers.
I want to check if a folder with selected customer name exists and create a folder if it is missing.
Once the customer folder is found or created, check if there is a folder for each article number and if it is missing, create one.
I found code that seems to do all that and more posted by Scott Holtzman.
I have referenced Microsoft Scripting Runtime as the code requests.
Both of the "If not" statements are marked red and the pop-up window only says "Compile error".
I checked the syntax of "If not" statements and it seems to be correct.
'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()
Dim strComp As String, strPart As String, strPath As String
strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"
If Not FolderExists(strPath & strComp) Then
'company doesn't exist, so create full path
FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strComp & "\" & strPart) Then
FolderCreate strPath & strComp & "\" & strPart
End If
End If
End Sub
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
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
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 CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters
CleanName = Replace(strName, "/","")
CleanName = Replace(CleanName, "*","")
' etc...
End Function
Take a look at the below example, it shows one of the possible approaches using recursive sub call:
Option Explicit
Sub TestArrays()
Dim aCustomers
Dim aArticles
Dim sCustomer
Dim sArticle
Dim sPath
sPath = "C:\Test"
aCustomers = Array("Customer01", "Customer02", "Customer03", "Customer04", "Customer05")
aArticles = Array("Article01", "Article02", "Article03", "Article04", "Article05")
For Each sCustomer In aCustomers
For Each sArticle In aArticles
SmartCreateFolder sPath & "\" & sCustomer & "\" & sArticle
Next
Next
End Sub
Sub TestFromSheet()
Dim aCustomers
Dim aArticles
Dim i
Dim j
Dim sPath
sPath = "C:\Test"
With ThisWorkbook.Sheets(1)
aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
aArticles = .Range("B1:B10").Value
End With
For i = LBound(aCustomers, 1) To UBound(aCustomers, 1)
For j = LBound(aArticles, 1) To UBound(aArticles, 1)
SmartCreateFolder sPath & "\" & aCustomers(i, 1) & "\" & aArticles(j, 1)
Next
Next
End Sub
Sub SmartCreateFolder(sFolder)
Static oFSO As Object
If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO
If Not .FolderExists(sFolder) Then
SmartCreateFolder .GetParentFolderName(sFolder)
.CreateFolder sFolder
End If
End With
End Sub
Sub TestArrays() checks and creates folders for customers and articles from the hardcoded arrays, and Sub TestFromSheet() gets customers and articles from the first worksheet, as an example customers range from A1 up to the last element, so it should be more than one element there, and articles set to fixed range B1:B10, like shown below:
The StrComp Issue
You cannot use StrComp, its a reserved word, actually a string function. I lost about 15 minutes the other day on this issue.
VBA says: Returns a Variant (Integer) indicating the result of a string comparison.
If you want to shorthand a bunch of that code, use MKDIR to create each level of folder\subfolder with error pass-over.
Option Explicit
Sub main()
Dim pth As String
pth = "c:\test\abc\123\test_again\XYZ\01-20-2019"
'folder may or may not exist
makeFolder pth
'folder definitely exists
End Sub
Sub makeFolder(fldr As String)
Dim i As Long, arr As Variant
'folder may or may not exist
arr = Split(fldr, Chr(92))
fldr = arr(LBound(arr))
On Error Resume Next
For i = LBound(arr) + 1 To UBound(arr)
fldr = Join(Array(fldr, arr(i)), Chr(92))
MkDir fldr
Next i
On Error GoTo 0
'folder definitely exists
End Sub
To rename an existing file to a new location WITH creation of all subdirectories, you can use:
File_Name_OLD = File_Pad_OLD & "Test.txt"
File_Pad_NEW = "e:\temp\test1\test2\test3\"
File_Name_NEW = File_Pad_NEW & "Test.txt"
X = File_Pad_NEW
A = 1
Do Until A = 0
A = InStr(X, "\")
Y = Y & Left(X, A)
X = Mid(X, A + 1)
If Dir(Y, 16) = "" Then MkDir Y
Loop
Name File_Name_OLD As File_Name_NEW
This is creating the new path with subdirectories and renames the old file to the new one.
How to get the size of the posters by using vba excel. I am using windows 7 operating system.
Images are present on some other path. Ex. d:\posterbank\a.jpeg,b.jpeg and excel file contains only names like a.jpeg, b.jpeg.
I want to check if these posters are there if yes need to check size of these.
A = LTrim(RTrim(Sheets(sheetno).Range("m" & rowno).Value))
postername = Left(A, Len(A) - 4) & ".bmp"
If filesys.fileExists(Poster_SPath & "\" & postername) Then
Else: Call appendtofile(vbrLf & "Not found " & Eng_Title & " " & postername, Logfile_Path & "\" & "log.txt")
End If
This should get you started :) I have taken the example of 1 picture, I am sure you can amend it to loop the relevant cells and pick up the values :)
TRIED AND TESTED
'~~> Path where images reside
Const FilePath As String = "C:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\"
Sub Sample()
Dim Filename As String
'~~> Replace this with the relevant cell value
Filename = "Sunset.JPG"
'~> Check if file exists
If FileFolderExists(FilePath & Filename) = True Then
'~~> In sheet 2 insert the image temporarily
With Sheets("Sheet2")
.Pictures.Insert(FilePath & Filename).Select
'~~> Get dimensions
MsgBox "Picture demensions: " & Selection.Width & " x " & Selection.Height
'~~> Delete the picture
Selection.Delete
End With
End If
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
This Worked for Me
Option Explicit
Type FileAttributes
Name As String
Dimension As String
End Type
Public Function GetFileAttributes(strFilePath As String) As FileAttributes
' Shell32 objects
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim objFolderItem As Shell32.FolderItem
' Other objects
Dim strPath As String
Dim strFileName As String
Dim i As Integer
' If the file does not exist then quit out
If Dir(strFilePath) = "" Then Exit Function
' Parse the file name out from the folder path
strFileName = strFilePath
i = 1
Do Until i = 0
i = InStr(1, strFileName, "\", vbBinaryCompare)
strFileName = Mid(strFileName, i + 1)
Loop
strPath = Left(strFilePath, Len(strFilePath) - Len(strFileName) - 1)
' Set up the shell32 Shell object
Set objShell = New Shell
' Set the shell32 folder object
Set objFolder = objShell.Namespace(strPath)
' If we can find the folder then ...
If (Not objFolder Is Nothing) Then
' Set the shell32 file object
Set objFolderItem = objFolder.ParseName(strFileName)
' If we can find the file then get the file attributes
If (Not objFolderItem Is Nothing) Then
GetFileAttributes.Dimension = objFolder.GetDetailsOf(objFolderItem, 36)
End If
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Function
Not tested, but using this as reference, it looks like it should be possible to load the image like this.
set myImg = loadpicture(Poster_SPath & "\" & postername & ".bmp")
And then get the width and height like this.
myImg.height
myImg.width