CreateProcessWithLogon Error requires elevation - windows

all
I am using CreateProcessWithLogon method to installing softwares for non autherized users to installing software, it was working fine for windows XP users, but same application shows the error as follows in windows 7 machine.
System.ComponentModel.Win32Exception(0x80004005): the requested operation requires elevation
please any one suggest me any idea to fix it.
i am using the code as follows
Private Const LOGON_NETCREDENTIALS_ONLY As Integer = &H2
Private Const NORMAL_PRIORITY_CLASS As Integer = &H20
Private Const CREATE_DEFAULT_ERROR_MODE As Integer = &H4000000
Private Const CREATE_NEW_CONSOLE As Integer = &H10
Private Const CREATE_NEW_PROCESS_GROUP As Integer = &H200
Private Const LOGON_WITH_PROFILE As Integer = &H1
Private Const LOGON_WITH_PROFILE1 As Integer = 0
Dim siStartup As STARTUPINFO
Dim piProcess As PROCESS_INFORMATION
Dim intReturn As Integer
Dim bResult As Boolean = False
Dim result As Integer
Dim sFile, sArg As String
IMP_USER_NAME = AppSettings("UserName")
IMP_PASS_WORD = AppSettings("Password")
IMP_DOMAIN_NAME = AppSettings("Domain")
Try
If sApplication.EndsWith(".msi") Then
sApplication = sApplication & " " & """ALLUSERS=1"""
sArg = "msiexec.exe /i """ & sApplication & """"
sFile = vbNullString
Else
If bToExecute = False Then
sArg = vbNullString
sFile = sApplication
Else
sArg = "cmd /c """ & sApplication & """"
sFile = vbNullString
End If
End If
siStartup.cb = Marshal.SizeOf(siStartup)
siStartup.dwFlags = 0
intReturn = CreateProcessWithLogon(IMP_USER_NAME, IMP_DOMAIN_NAME, IMP_PASS_WORD, LOGON_WITH_PROFILE, sFile, sArg, _
NORMAL_PRIORITY_CLASS Or CREATE_DEFAULT_ERROR_MODE Or CREATE_NEW_CONSOLE Or CREATE_NEW_PROCESS_GROUP, _
IntPtr.Zero, IntPtr.Zero, siStartup, piProcess)
Thanks,
Senthil

See http://blogs.msdn.com/b/cjacks/archive/2010/02/01/why-can-t-i-elevate-my-application-to-run-as-administrator-while-using-createprocesswithlogonw.aspx : you need an intermediate process that execute ShellExec() to elevate the priveleges of an application called with CreateProcessWithLogon
Alternativeley, you can call cmd /c cd <targetDir>&<targetDrive>:&<execName> with CreateProcessWithLogon to avoid creating that intermediate process.

Probably the reason is that you use LOGON_WITH_PROFILE flag. In the "Remark" part of the CreateProcessWithLogonW documentation you can read following
By default, CreateProcessWithLogonW
does not load the specified user
profile into the HKEY_USERS registry
key. This means that access to
information in the HKEY_CURRENT_USER
registry key may not produce results
that are consistent with a normal
interactive logon. It is your
responsibility to load the user
registry hive into HKEY_USERS before
calling CreateProcessWithLogonW, by
using LOGON_WITH_PROFILE, or by
calling the LoadUserProfile function.
So I recommend you to try the same code without LOGON_WITH_PROFILE flag. If you will see that it was the problem and you do need to use the flag you should use LoadUserProfile function and UnloadUserProfile in your code.

Related

Launch process under another user account

Below is the sequence of Process calling;
Service calling Process A (this causes Process A to run under local system account).
Process A launching Process B under different user account (non admin user) using CreateProcessWithLogonW API (as logon credentials of different user is available).
Process B performing some activity which involves invoking another process.
Up to step 2 everything works fine. Process B launched under given user account but Process B is not able to perform a task like executing batch file or launching one more process using CreateProcess API.
Below is the code for invoking Process B;
Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION
Dim wUser As String
Dim wDomain As String
Dim wPassword As String
Dim wCommandLine As String
Dim wCurrentDir As String
Dim wApplicaiotnName
Dim Result As Long
si.cb = Len(si)
si.lpDesktop = "WinSta0\Default"
Result = CreateProcessWithLogonW(wUser, wDomain, wPassword, _LOGON_WITH_PROFILE,
wApplicaiotnName, "", _CREATE_UNICODE_ENVIRONMENT, 0&, wCurrentDir, si, pi)
And below code used in Process B to execute batch file;
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret As Long
Dim lpId As Long
Dim llReturn As Long
Dim RetVal As Long
With start
.cb = Len(start)
.lpDesktop = "WinSta0\Default"
If Not IsMissing(WindowStyle) Then
.dwFlags = STARTF_USESHOWWINDOW
.wShowWindow = WindowStyle
End If
End With
ret& = CreateProcessA(0&, pathName, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

Can I PrintToFIle in Access, or possibly spoof the fax driver to create Tifs?

I built calculator in Access using a user form. The goal of the calculator is to document the steps taken by the user in solving a problem. It's similar to a high-school student being told to 'show their work'. I need to record a visual representation of the form. A PDF would be perfected, but I can't use PDFs.
I'm limited to file formats that are supported by our imaging server.
I know that the imaging server supports: tif, jpg, bmp and rtf. It might support other formats.
I know that these formats don't work: pdf, gif and png.
I'm an inexperienced coder (less than 6 mos), and I came up with a solution which I suspect is subpar. Occasionally, it seems to just stop working.
Essentially, I copy the form using keybd_event, and paste it into a word document, and save it as a tif file.
Is there a more conventional way of accomplishing this?
Here's my code:
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Public Sub sendToFaf()
Dim appWord As New Word.Application
Dim docWord As New Word.Document
Dim imgWord As InlineShape
Dim thisForm As Form
Dim oldPrinter As String
Dim rnd As Integer
Dim strRnd As String
Dim oldWidth As Integer
Dim oldHeight As Integer
On Error GoTo ProcessError
DoCmd.Echo (False)
DoCmd.Hourglass (True)
Set appWord = CreateObject("word.application")
Set docWord = appWord.Documents.Add
Set thisForm = Screen.ActiveForm
appWord.Visible = False
appWord.DisplayAlerts = wdAlertsNone
oldWidth = thisForm.InsideWidth
oldHeight = thisForm.InsideHeight
thisForm.InsideWidth = 10800
thisForm.InsideHeight = 11925
keybd_event VK_MENU, 0, 0, 0
DoEvents
keybd_event VK_SNAPSHOT, 0, 0, 0
DoEvents
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
DoEvents
thisForm.InsideWidth = oldWidth
thisForm.InsideHeight = oldHeight
rnd = Int((10000 - 0 + 1) * Math.rnd + 0)
strRnd = Format(rnd, "0000")
With docWord.PageSetup
.TopMargin = 0
.BottomMargin = 0
.LeftMargin = 0
.RightMargin = 0
.VerticalAlignment = wdAlignVerticalCenter
End With
docWord.Paragraphs.Alignment = wdAlignParagraphCenter
appWord.Selection.Paste
Set imgWord = docWord.InlineShapes(docWord.InlineShapes.Count)
imgWord.Width = InchesToPoints(8.5)
oldPrinter = appWord.ActivePrinter
appWord.ActivePrinter = "FAX"
appWord.PrintOut _
Background:=False, _
outputfilename:="c:\a faf\" & thisForm.Name & strRnd & ".tif", _
PrintToFile:=True
MsgBox ("File created: 'c:\a faf\" & thisForm.Name & strRnd & ".tif'")
appWord.ActivePrinter = oldPrinter
ProcessExit:
Set imgWord = Nothing
docWord.Close savechanges:=wdDoNotSaveChanges
appWord.Quit savechanges:=wdDoNotSaveChanges
Set docWord = Nothing
Set appWord = Nothing
Set thisForm = Nothing
DoCmd.Echo (True)
DoCmd.Hourglass (False)
Exit Sub
ProcessError:
MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & "Sub SendToFaf"
GoTo ProcessExit
End Sub

Visual Basic: Adding users and group

I'm updating an installer and need to create a Windows group and add (existing) users to that group.
The users are IIS pseudo-users, ie IIS APPPOOL\username
Is there a simple way to do this using VB6 or VB.NET? I can't find an obvious library/API or any example code
Thanks
You can try the following code extracted from this link to create users. Basically it uses the API NetUserAdd.
Option Explicit
' ---------------------------------------------
' The USER_INFO_3 data structure
' ---------------------------------------------
Private Type USER_INFO_3
usri3_name As Long
usri3_password As Long
usri3_password_age As Long
usri3_priv As Long
usri3_home_dir As Long
usri3_comment As Long
usri3_flags As Long
usri3_script_path As Long
usri3_auth_flags As Long
usri3_full_name As Long
usri3_usr_comment As Long
usri3_parms As Long
usri3_workstations As Long
usri3_last_logon As Long
usri3_last_logoff As Long
usri3_acct_expires As Long
usri3_max_storage As Long
usri3_units_per_week As Long
usri3_logon_hours As Long
usri3_bad_pw_count As Long
usri3_num_logons As Long
usri3_logon_server As Long
usri3_country_code As Long
usri3_code_page As Long
usri3_user_id As Long
usri3_primary_group_id As Long
usri3_profile As Long
usri3_home_dir_drive As Long
usri3_password_expired As Long
End Type
' ---------------------------------------------
' Possible errors with API call
' ---------------------------------------------
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const NERR_BASE As Long = 2100
Private Const NERR_GroupExists As Long = NERR_BASE + 123
Private Const NERR_NotPrimary As Long = NERR_BASE + 126
Private Const NERR_UserExists As Long = NERR_BASE + 124
Private Const NERR_PasswordTooShort As Long = NERR_BASE + 145
Private Const NERR_InvalidComputer As Long = NERR_BASE + 251
Private Const NERR_Success As Long = 0&
Private Const TIMEQ_FOREVER As Long = -1&
Private Const DOMAIN_GROUP_RID_USERS As Long = &H201&
Private Const USER_MAXSTORAGE_UNLIMITED As Long = -1&
Private Const constUserInfoLevel3 As Long = 3
' ---------------------------------------------
' Used by usri3_flags element of data structure
' ---------------------------------------------
Private Const UF_SCRIPT As Long = &H1&
Private Const UF_ACCOUNTDISABLE As Long = &H2&
Private Const UF_HOMEDIR_REQUIRED As Long = &H8&
Private Const UF_LOCKOUT As Long = &H10&
Private Const UF_PASSWD_NOTREQD As Long = &H20&
Private Const UF_PASSWD_CANT_CHANGE As Long = &H40&
Private Const UF_DONT_EXPIRE_PASSWD As Long = &H10000
Private Const STILL_ACTIVE As Long = &H103&
Private Const UF_NORMAL_ACCOUNT As Long = &H200&
Private Const UF_SERVER_TRUST_ACCOUNT As Long = &H2000&
Private Const PROCESS_QUERY_INFORMATION As Long = &H400&
Private Const UF_TEMP_DUPLICATE_ACCOUNT As Long = &H100&
Private Const UF_INTERDOMAIN_TRUST_ACCOUNT As Long = &H800&
Private Const UF_WORKSTATION_TRUST_ACCOUNT As Long = &H1000&
Private Declare Function NetUserAdd Lib "netapi32.dll" (ServerName As Byte, ByVal Level As Long, Buffer As USER_INFO_3, parm_err As Long) As Long
Private Declare Function NetApiBufferAllocate Lib "netapi32.dll" (ByVal ByteCount As Long, Ptr As Long) As Long
Private Declare Function NetApiBufferFree Lib "Netapi32" (ByVal pBuffer As Long) As Long
' *******************************************************
' Add a user either to NT -- you *MUST* have admin or
' account operator privileges to successfully run
' this function
' Use on NT Only
' *******************************************************
Public Function AddUser(ByVal xi_strServerName As String, _
ByVal xi_strUserName As String, _
ByVal xi_strPassword As String, _
Optional ByVal xi_strUserFullName As String = vbNullString, _
Optional ByVal xi_strUserComment As String = vbNullString) As Boolean
Dim p_strErr As String
Dim p_lngRtn As Long
Dim p_lngPtrUserName As Long
Dim p_lngPtrPassword As Long
Dim p_lngPtrUserFullName As Long
Dim p_lngPtrUserComment As Long
Dim p_lngParameterErr As Long
Dim p_lngFlags As Long
Dim p_abytServerName() As Byte
Dim p_abytUserName() As Byte
Dim p_abytPassword() As Byte
Dim p_abytUserFullName() As Byte
Dim p_abytUserComment() As Byte
Dim p_typUserInfo3 As USER_INFO_3
If xi_strUserFullName = vbNullString Then
xi_strUserName = xi_strUserName
End If
' ------------------------------------------
' Create byte arrays to avoid Unicode hassles
' ------------------------------------------
p_abytServerName = xi_strServerName & vbNullChar
p_abytUserName = xi_strUserName & vbNullChar
p_abytUserFullName = xi_strUserFullName & vbNullChar
p_abytPassword = xi_strPassword & vbNullChar
p_abytUserComment = xi_strUserComment & vbNullChar
' ------------------------------------------
' Allocate buffer space
' ------------------------------------------
p_lngRtn = NetApiBufferAllocate(UBound(p_abytUserName), p_lngPtrUserName)
p_lngRtn = NetApiBufferAllocate(UBound(p_abytUserFullName), p_lngPtrUserFullName)
p_lngRtn = NetApiBufferAllocate(UBound(p_abytPassword), p_lngPtrPassword)
p_lngRtn = NetApiBufferAllocate(UBound(p_abytUserComment), p_lngPtrUserComment)
' ------------------------------------------
' Get pointers to the byte arrays
' ------------------------------------------
p_lngPtrUserName = VarPtr(p_abytUserName(0))
p_lngPtrUserFullName = VarPtr(p_abytUserFullName(0))
p_lngPtrPassword = VarPtr(p_abytPassword(0))
p_lngPtrUserComment = VarPtr(p_abytUserComment(0))
' ------------------------------------------
' Fill the VB structure
' ------------------------------------------
p_lngFlags = UF_NORMAL_ACCOUNT Or UF_SCRIPT Or UF_DONT_EXPIRE_PASSWD
With p_typUserInfo3
.usri3_acct_expires = TIMEQ_FOREVER ' Never expires
.usri3_comment = p_lngPtrUserComment ' Comment
.usri3_flags = p_lngFlags ' There are a number of variations
.usri3_full_name = p_lngPtrUserFullName ' User's full name
.usri3_max_storage = USER_MAXSTORAGE_UNLIMITED ' Can use any amount of disk space
.usri3_name = p_lngPtrUserName ' Name of user account
.usri3_password = p_lngPtrPassword ' Password for user account
.usri3_primary_group_id = DOMAIN_GROUP_RID_USERS ' You MUST use this constant for NetUserAdd
.usri3_script_path = 0& ' Path of user's logon script
.usri3_auth_flags = 0& ' Ignored by NetUserAdd
.usri3_bad_pw_count = 0& ' Ignored by NetUserAdd
.usri3_code_page = 0& ' Code page for user's language
.usri3_country_code = 0& ' Country code for user's language
.usri3_home_dir = 0& ' Can specify path of home directory of this user
.usri3_home_dir_drive = 0& ' Drive letter assign to user's profile
.usri3_last_logoff = 0& ' Not needed when adding a user
.usri3_last_logon = 0& ' Ignored by NetUserAdd
.usri3_logon_hours = 0& ' Null means no restrictions
.usri3_logon_server = 0& ' Null means logon to domain server
.usri3_num_logons = 0& ' Ignored by NetUserAdd
.usri3_parms = 0& ' Used by specific applications
.usri3_password_age = 0& ' Ignored by NetUserAdd
.usri3_password_expired = 0& ' None-zero means user must change password at next logon
.usri3_priv = 0& ' Ignored by NetUserAdd
.usri3_profile = 0& ' Path to a user's profile
.usri3_units_per_week = 0& ' Ignored by NetUserAdd
.usri3_user_id = 0& ' Ignored by NetUserAdd
.usri3_usr_comment = 0& ' User comment
.usri3_workstations = 0& ' Workstations a user can log onto (null = all stations)
End With
' ------------------------------------------
' Attempt to add the user
' ------------------------------------------
p_lngRtn = NetUserAdd(p_abytServerName(0), _
constUserInfoLevel3, _
p_typUserInfo3, _
p_lngParameterErr)
' ------------------------------------------
' Check for error
' ------------------------------------------
If p_lngRtn <> 0 Then
AddUser = False
Select Case p_lngRtn
Case ERROR_ACCESS_DENIED
p_strErr = "User doesn't have sufficient access rights."
Case NERR_GroupExists
p_strErr = "The group already exists."
Case NERR_NotPrimary
p_strErr = "Can only do this operation on the PDC of the domain."
Case NERR_UserExists
p_strErr = "The user account already exists."
Case NERR_PasswordTooShort
p_strErr = "The password is shorter than required."
Case NERR_InvalidComputer
p_strErr = "The computer name is invalid."
Case Else
p_strErr = "Unknown error #" & CStr(p_lngRtn)
End Select
On Error GoTo 0
Err.Raise Number:=p_lngRtn, _
Description:=p_strErr & vbCrLf & _
"Error in parameter " & p_lngParameterErr & _
" when attempting to add the user, " & xi_strUserName, _
Source:="Form1.AddUser"
Else
AddUser = True
End If
' ------------------------------------------
' Be a good programmer and free the memory
' you've allocated
' ------------------------------------------
p_lngRtn = NetApiBufferFree(p_lngPtrUserName)
p_lngRtn = NetApiBufferFree(p_lngPtrPassword)
p_lngRtn = NetApiBufferFree(p_lngPtrUserFullName)
p_lngRtn = NetApiBufferFree(p_lngPtrUserComment)
End Function
EDIT:
I have found the following example in msdn:
Option Explicit
On Error Resume Next
Dim scriptResult ' Script success or failure
Dim groupPath ' ADsPath to the group container
Dim group ' Group object
Dim memberPath ' ADsPath to the member
Dim member ' Member object
Dim groupMemberList ' Used to display group members
Dim errorText ' Error handing text
scriptResult = False
groupPath =
"LDAP://fabrikam.com/CN=TestGroup,OU=TestOU,DC=fabrikam,DC=com"
memberPath = "LDAP://CN=JeffSmith,OU=TestOU,DC=fabrikam,DC=com"
WScript.Echo("Retrieving group object")
Set group = GetObject(groupPath)
If Err.number <> vbEmpty then
Call ErrorHandler("Could not create group object.")
End If
Call ShowMembers(groupPath) 'Optional function call
WScript.Echo("Retrieving new member object")
Set member = GetObject(memberPath)
If Err.number <> vbEmpty then
Call ErrorHandler("Could not get new member object.")
End If
WScript.Echo("Adding member to group.")
group.Add(member.ADsPath)
If Err.number <> vbEmpty then
Call ErrorHandler("Could not add member to group.")
End If
Call ShowMembers(groupPath) ' Optional function call
scriptResult = True
Call FinalResult(scriptResult)
'****************************************************************
' This function displays the members of a group. The function
' takes the ADsPath of the group.
'****************************************************************
Sub ShowMembers(groupPath)
Dim groupMember
Dim groupMemberList
Dim groupObject
Set groupObject = GetObject(groupPath)
Set groupMemberList = groupObject.Members
Select Case groupMemberList.Count
Case 1
WScript.Echo vbcrlf & "The group has one member."
Case 0
WScript.Echo vbcrlf & "The group has no members."
Case Else
WScript.Echo vbcrlf & "The group has " &
groupMemberList.Count &
" members."
End Select
If groupMemberList.Count > 0 then
WScript.Echo vbcrlf & "Here is a member list."
For Each groupMember in groupMemberList
WScript.Echo groupMember.Name
Next
WScript.Echo vbcrlf
End If
Set groupObject = Nothing
Set groupMemberList = Nothing
End Sub
'****************************************************************
' This function shows if the script succeeded or failed. The
' function processed the scriptResult variable.
'****************************************************************
Sub FinalResult(scriptResult)
WScript.Echo vbcrlf
If scriptResult = False then
WScript.Echo "Script failed."
Else
WScript.Echo("Script successfully completed.")
End If
WScript.Quit
End Sub
'****************************************************************
' This function handles errors that occur in the script.
'****************************************************************
Sub ErrorHandler( errorText )
WScript.Echo(vbcrlf & errorText)
WScript.Echo("Error number: " & Err.number)
WScript.Echo("Error Description: " & Err.Description)
Err.Clear
Call FinalResult(scriptResult)
End Sub
Alternatively, you can use Windows Script Host to execute the net tool:
Set objShell = CreateObject("Wscript.Shell")
strCommand = "net localgroup Administrators /add DOMAIN\USERNAME"
Set objExec = objShell.Exec(strCommand)

Failed to get Windows Serial Number in Windows 7

I am trying to get the Windows Serial Number in Windows 7 with my VB6 application. However, it always fails to retrieve it.
SScript.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductId")
It returns the following error:
Unable to open registry key "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductId" for reading.
In Win XP, it will be successful to retrieve the serial number. I don't know whether Windows 7 has prohibited a VB6 application to get the Windows serial number.
Please help. Thank you!
It is peculiar isn't it? Try adding this const to your delcarations and OR the value to your open registry call. There is a very good explanation in the answer to KEY_WOW64_32KEY and KEY_WOW64_64KEY.
Private Const KEY_WOW64_64KEY As Long = &H100& '32 bit app to access 64 bit hive
Private Function GetWindowsProductId() As String
Dim strReturn As String
Dim strBuffer As String
Dim lngType As Long
Dim lngBufLen As Long
Dim lngRst As Long
Dim hKeyHandle As Long
lngRst = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion", 0, KEY_READ Or KEY_WOW64_64KEY, hKeyHandle)
If hKeyHandle <> 0 Then
strBuffer = String(255, vbNullChar)
lngBufLen = Len(strBuffer)
lngRst = RegQueryValueEx(hKeyHandle, "ProductId", ByVal 0&, lngType, ByVal strBuffer, lngBufLen)
If lngRst = 0 Then
If lngType = REG_SZ Then
If lngBufLen > 0 Then
strReturn = Left$(strBuffer, lngBufLen - 1)
Else
strReturn = "nothing was returned"
End If
Else
strReturn = "there was an error"
End If
ElseIf lngRst = 2 Then 'the key does not exist
strReturn = "the key was not found"
Else 'if the return is non-zero there was an error
strReturn = "There was an error " & CStr(lngRst) & " reading the key"
End If
End If
GetWindowsProductId = strReturn
End Function

Where is Outlook's save FileDialog?

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

Resources