Ok use this.....It works wonderfully for me.....
Copy and paste it into a new VBA Module, then select FixPreview from the Macro list.
Option Explicit
Private Declare Function GetCurrentVbaProject _
Lib "vba332.dll" Alias "EbGetExecutingProj" _
(hProject As Long) As Long
Private Declare Function GetFuncID _
Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hProject As Long, ByVal strFunctionName As String, _
ByRef strFunctionId As String) As Long
Private Declare Function GetAddr _
Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _
(ByVal hProject As Long, ByVal strFunctionId As String, _
ByRef lpfn As Long) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Const MAX_PATH = 2600
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Public Declare Function LocalAlloc Lib "kernel32" _
(ByVal uFlags As Long, _
ByVal uBytes As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal dwLength As Long)
Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal HWND As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Public Function ReturnFolder(Title As String) As String
Dim Browser As BROWSEINFO
Dim lngFolder As Long
Dim strPath As String
Dim sSelPath As String
Dim lpSelPath As Long
'Change the path "C:\Drawings" to point to your default folder
sSelPath = GetSetting("ReturnFolder", "Path", "Last", "C:\Drawings")
lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
With Browser
.hOwner = 0&
.lpszTitle = Title
.pszDisplayName = String(MAX_PATH, 0)
.pidlRoot = 0
.lpfn = AddrOf("BrowseCallbackProcStr")
.lParam = lpSelPath
End With
SendMessage 0&, BFFM_SETSELECTIONW, True, ByVal lpSelPath
strPath = String(MAX_PATH, 0) '<-- VERY Important!!
lngFolder = SHBrowseForFolder(Browser)
If lngFolder Then
SHGetPathFromIDList lngFolder, strPath
ReturnFolder = Left(strPath, InStr(strPath, vbNullChar) - 1)
SaveSetting "ReturnFolder", "Path", "Last", Left(strPath, InStr(strPath, vbNullChar) - 1)
End If
End Function
Public Function BrowseCallbackProcStr(ByVal HWND As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse STRING method.
'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(HWND, BFFM_SETSELECTIONA, _
True, ByVal lpData)
Case Else:
End Select
End Function
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
' The function name must be in Unicode, so convert it.
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
' Get the current VBA project
' The results of GetCurrentVBAProject seemed inconsistent, in our tests,
' so now we just check the project handle when the function returns.
Call GetCurrentVbaProject(hProject)
' Make sure we got a project handle... we always should, but you never know!
If hProject <> 0 Then
' Get the VBA function ID (whatever that is!)
lngResult = GetFuncID( _
hProject, strFuncNameUnicode, strID)
' We have to check this because we GPF if we try to get a function pointer
' of a non-existent function.
If lngResult = NO_ERROR Then
' Get the function pointer.
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
Sub FixPreview()
Dim CurrentDwg As AcadDocument
Dim File As Variant
Dim Folder As String
ThisDrawing.SetVariable "Acadlspasdoc", 0
Folder = ReturnFolder("File location to generate previews: ")
File = Dir(Folder & "\*.DWG")
While File <> ""
Set CurrentDwg = Application.Documents.Open(Folder & "\" & File)
CurrentDwg.Activate
Application.ZoomExtents
CurrentDwg.Close True
Set CurrentDwg = Nothing
File = Dir
Wend
ThisDrawing.SetVariable "Acadlspasdoc", 1
End Sub
Comments?