2019-09-29 12:45:23 +00:00
Imports System . Reflection . Assembly
2019-11-13 19:09:43 +00:00
Imports System . Windows . Forms
2019-09-29 12:45:23 +00:00
Public Class RDP
Private rdpFilePath As String
Public Property rdpPath As String
Get
Return rdpFilePath
End Get
Set ( value As String )
rdpFilePath = value
ReadRDPfile ( )
End Set
End Property
Private ProductName As String ' Full remoteapp name as read from RDP file
Public FlatFileTypes As String = " "
Public PerUser As Boolean = False
Private ProductBaseFileName As String ' RDP filename minus the file extension
Public ProductPublisher As String
Public ProductVersion As String = " 1.0.0.0 "
Public ProductUpgradeRandom As Boolean = False
Public ProductRemoteTag As String = " remote "
Public ShortcutInStart As Boolean = True
Public ShortcutSubfolderInStart As Boolean = True
Public ShortcutOnDesktop As Boolean = True
Private rdpFileContents As String
Private hasIcon As Boolean
Private rdpInTemp As Boolean
Public Sub CreateMSI ( Optional DestinationPath As String = " " )
'Check for wix, exit if not available
If Not WixInstalled ( ) Then Exit Sub
'Get RDP file parent folder path
2023-01-08 05:47:58 +00:00
'Dim rdpParentFolder = My.Computer.FileSystem.GetParentPath(rdpFilePath)
Dim lastSlashIndex = rdpFilePath . LastIndexOf ( " \ " )
Dim rdpParentFolder = Left ( rdpFilePath , lastSlashIndex )
2019-09-29 12:45:23 +00:00
'Get the RDP filename and filename minus extension
Dim rdpFileName = My . Computer . FileSystem . GetFileInfo ( rdpFilePath ) . Name
ProductBaseFileName = System . IO . Path . GetFileNameWithoutExtension ( rdpFileName )
'If DestinationPath not defined then set the path to the same as the rdp file
If DestinationPath = " " Then DestinationPath = rdpParentFolder & " \ " & ProductBaseFileName & " .msi "
'Set iconpath (whether it exists or not)
Dim IconFilePath = rdpParentFolder & " \ " & ProductBaseFileName & " .ico "
'Check for icon, set "HasIcon" to true if found
hasIcon = My . Computer . FileSystem . FileExists ( IconFilePath )
'Get RemoteApp names (short and full) from RDP file contents
Dim RemoteAppFullName = ReadRDPProperty ( " remoteapplicationname " )
Dim RemoteAppShortName = ReadRDPProperty ( " remoteapplicationprogram " )
'Define wix temp file paths
Dim TempPath = Environment . GetEnvironmentVariable ( " TEMP " )
Dim wxsPath = TempPath & " \ " & ProductBaseFileName & " .wxs "
Dim wixobjPath = TempPath & " \ " & ProductBaseFileName & " .wixobj "
Dim wixpdbPath = TempPath & " \ " & ProductBaseFileName & " .wixpdb "
Dim msiPath = TempPath & " \ " & ProductBaseFileName & " .msi "
Dim rdpTempPath = TempPath & " \ " & ProductBaseFileName & " .rdp "
Dim icoTempPath = TempPath & " \ " & ProductBaseFileName & " .ico "
'Define temp files to delete
Dim FilesToDelete As List ( Of String ) = New List ( Of String ) ( New String ( ) { wxsPath , wixobjPath , wixpdbPath } )
2019-11-13 19:09:43 +00:00
Dim LockCheck As New LockChecker . LockChecker ( )
Dim FileLocked As String
Dim SkipFile As Boolean = False
2019-09-29 12:45:23 +00:00
'Check if rdp file is already in TEMP folder
If rdpParentFolder = TempPath Then rdpInTemp = True
'if RDP file not in temp, copy to temp
If Not rdpInTemp Then
2019-11-13 19:09:43 +00:00
FileLocked = LockCheck . CheckLock ( rdpTempPath )
While Not ( FileLocked = " No locks " )
If ( MessageBox . Show ( " The file " + rdpTempPath + " is currently locked. Lock information: " + FileLocked + vbNewLine + " Do you want to try again? " , " File Locked " , MessageBoxButtons . YesNo ) = DialogResult . Yes ) Then
FileLocked = LockCheck . CheckLock ( rdpTempPath )
Else
MessageBox . Show ( " The following file will not be deleted: " + vbNewLine + rdpTempPath )
SkipFile = True
FileLocked = " No locks "
End If
End While
If Not ( SkipFile ) Then
My . Computer . FileSystem . CopyFile ( rdpFilePath , rdpTempPath , True )
End If
2019-09-29 12:45:23 +00:00
FilesToDelete . Add ( rdpTempPath )
If hasIcon Then
2019-11-13 19:09:43 +00:00
FileLocked = LockCheck . CheckLock ( icoTempPath )
While Not ( FileLocked = " No locks " )
If ( MessageBox . Show ( " The file " + icoTempPath + " is currently locked. Lock information: " + FileLocked + vbNewLine + " Do you want to try again? " , " File Locked " , MessageBoxButtons . YesNo ) = DialogResult . Yes ) Then
FileLocked = LockCheck . CheckLock ( icoTempPath )
Else
MessageBox . Show ( " The following file will not be deleted: " + vbNewLine + icoTempPath )
SkipFile = True
FileLocked = " No locks "
End If
End While
If Not ( SkipFile ) Then
My . Computer . FileSystem . CopyFile ( IconFilePath , icoTempPath , True )
End If
2019-09-29 12:45:23 +00:00
FilesToDelete . Add ( icoTempPath )
End If
End If
'Save WXS file containing generated WXS string
My . Computer . FileSystem . WriteAllText ( wxsPath , GenerateWXSString ( ) , False )
Dim CandlePath = WixPath ( ) & " \candle.exe "
Dim LightPath = WixPath ( ) & " \light.exe "
'Run Candle.exe and Light.exe to process wxs file
Dim CandleExitCode = RunWait ( CandlePath , " -out "" " & wixobjPath & " "" "" " & wxsPath & " "" " )
'If Not CandleExitCode = 0 Then Exit Sub
Dim LightExitCode = RunWait ( LightPath , " -out "" " & msiPath & " "" "" " & wixobjPath & " "" " )
'If Not LightExitCode = 0 Then Exit Sub
'Move MSI file to destination and delete temp files
2019-11-13 19:09:43 +00:00
FileLocked = LockCheck . CheckLock ( DestinationPath )
While Not ( FileLocked = " No locks " )
If ( MessageBox . Show ( " The file " + DestinationPath + " is currently locked. Lock information: " + FileLocked + vbNewLine + " Do you want to try again? " , " File Locked " , MessageBoxButtons . YesNo ) = DialogResult . Yes ) Then
FileLocked = LockCheck . CheckLock ( DestinationPath )
Else
MessageBox . Show ( " The following file will not be deleted: " + vbNewLine + DestinationPath )
SkipFile = True
FileLocked = " No locks "
End If
End While
If Not ( SkipFile ) Then
My . Computer . FileSystem . MoveFile ( msiPath , DestinationPath , True )
End If
2019-09-29 12:45:23 +00:00
DeleteFiles ( FilesToDelete )
End Sub
Public Function WixInstalled ( ) As Boolean
If WixPath ( ) = " " Then
WixInstalled = False
Else
WixInstalled = True
End If
End Function
Private Function WixPath ( )
2023-06-14 17:40:47 +00:00
Dim searchExe = " candle.exe "
2019-09-29 12:45:23 +00:00
WixPath = " "
If Not Environment . GetEnvironmentVariable ( " WIX " ) = " " Then
WixPath = Environment . GetEnvironmentVariable ( " WIX " ) & " bin "
2023-06-14 17:40:47 +00:00
ElseIf My . Computer . FileSystem . FileExists ( My . Application . Info . DirectoryPath & " \wix\ " & searchExe ) Then
2019-09-29 12:45:23 +00:00
WixPath = My . Application . Info . DirectoryPath & " \wix "
2023-06-14 17:40:47 +00:00
ElseIf My . Computer . FileSystem . FileExists ( My . Application . Info . DirectoryPath & " \wix\bin\ " & searchExe ) Then
2019-09-29 12:45:23 +00:00
WixPath = My . Application . Info . DirectoryPath & " \wix\bin "
End If
End Function
Private Sub DeleteFiles ( FilesArray As List ( Of String ) )
For Each dFile In FilesArray
2019-11-13 19:09:43 +00:00
Dim LockCheck As New LockChecker . LockChecker ( )
Dim FileLocked As String
Dim SkipFile As Boolean = False
FileLocked = LockCheck . CheckLock ( dFile )
While Not ( FileLocked = " No locks " )
If ( MessageBox . Show ( " The file " + dFile + " is currently locked. Lock information: " + FileLocked + vbNewLine + " Do you want to try again? " , " File Locked " , MessageBoxButtons . YesNo ) = DialogResult . Yes ) Then
FileLocked = LockCheck . CheckLock ( dFile )
Else
MessageBox . Show ( " The following file will not be deleted: " + vbNewLine + dFile )
SkipFile = True
FileLocked = " No locks "
End If
End While
If Not ( SkipFile ) Then
If My . Computer . FileSystem . FileExists ( dFile ) Then My . Computer . FileSystem . DeleteFile ( dFile )
End If
2019-09-29 12:45:23 +00:00
Next
End Sub
Private Sub ReadRDPfile ( )
'Check if RDP file exists
If Not My . Computer . FileSystem . FileExists ( rdpFilePath ) Then Exit Sub
'Check that RDP file is an RDP file
If Not rdpFilePath . ToLower . EndsWith ( " .rdp " ) Then Exit Sub
'Read RDP file into variable
rdpFileContents = My . Computer . FileSystem . ReadAllText ( rdpFilePath )
'Check RDP file contains a remoteapplicationname value
'If ReadRDPProperty("remoteapplicationname") = "" Then Exit Sub
'Check if RDP file contains a server address
If ReadRDPProperty ( " full address " ) = " " Then Exit Sub
'Read variables
ProductName = ReadRDPProperty ( " remoteapplicationname " )
If ProductName = " " Then
ProductName = System . IO . Path . GetFileNameWithoutExtension ( rdpFilePath )
End If
If ProductPublisher Is Nothing Then ProductPublisher = ProductName
End Sub
Public Function ProductUpgradeCode ( )
' random or generated - maybe allow caller to define?
Dim UpgradeCode As String
'Check if ProductUpgradeRandom is true, create a random productcode if so, otherwise generate it from the productname
If Not ProductUpgradeRandom Then
UpgradeCode = GenerateGUIDfromString ( ProductName )
Else
Dim Rnd = New Random ( )
UpgradeCode = GenerateGUIDfromString ( Rnd . Next )
End If
Return UpgradeCode
End Function
Public Function MakeProgID ( AppName ) As String
Dim rx As New System . Text . RegularExpressions . Regex ( " [^a-zA-Z0-9_] " )
MakeProgID = rx . Replace ( AppName , " _ " )
End Function
Private Function GenerateWXSString ( )
Dim Rnd = New Random ( )
If ProductPublisher = " " Then ProductPublisher = ProductName
Dim RegRoot = " HKLM "
If PerUser = True Then RegRoot = " HKCU "
Dim AppFilesGuid = GenerateGUIDfromString ( " AppFiles " & ProductUpgradeCode ( ) )
Dim AppStartShortcutsGuid = GenerateGUIDfromString ( " AppStartShortcuts " & ProductUpgradeCode ( ) )
Dim AppDeskShortcutsGuid = GenerateGUIDfromString ( " AppDeskShortcuts " & ProductUpgradeCode ( ) )
Dim ProgID As String = MakeProgID ( ProductBaseFileName )
Dim wxsString = " <?xml version= "" 1.0 "" ?> " & vbCrLf
wxsString += " <?define ProductVersion = "" " & ProductVersion & " "" ?> " & vbCrLf
wxsString += " <?define ProductUpgradeCode = "" " & ProductUpgradeCode ( ) & " "" ?> " & vbCrLf
wxsString += " <?define AppFilesGuid = "" " & AppFilesGuid & " "" ?> " & vbCrLf
wxsString += " <?define AppStartShortcutsGuid = "" " & AppStartShortcutsGuid & " "" ?> " & vbCrLf
wxsString += " <?define AppDeskShortcutsGuid = "" " & AppDeskShortcutsGuid & " "" ?> " & vbCrLf
wxsString += " <?define ProductName = "" " & ProductName & " "" ?> " & vbCrLf
wxsString += " <?define ProductPublisher = "" " & ProductPublisher & " "" ?> " & vbCrLf
wxsString += " <?define ProductBaseFileName = "" " & ProductBaseFileName & " "" ?> " & vbCrLf
wxsString += " <?define RegRoot = "" " & RegRoot & " "" ?> " & vbCrLf
If Not FlatFileTypes = " " Then wxsString += " <?define ProductProgID = "" " & ProgID & " "" ?> " & vbCrLf
If Not ProductRemoteTag = " " Then ProductRemoteTag = " ( " & ProductRemoteTag & " ) "
wxsString += " <?define ProductRemoteTag = "" " & ProductRemoteTag & " "" ?> " & vbCrLf
wxsString += " <Wix xmlns= "" http://schemas.microsoft.com/wix/2006/wi "" > " & vbCrLf
wxsString += " <Product Id= "" * "" UpgradeCode= "" $(var.ProductUpgradeCode) "" " & vbCrLf
wxsString += " Name= "" $(var.ProductName)$(var.ProductRemoteTag) "" Version= "" $(var.ProductVersion) "" Manufacturer= "" $(var.ProductPublisher) "" Language= "" 1033 "" > " & vbCrLf
wxsString += " <Package InstallerVersion= "" 200 "" Compressed= "" yes "" Comments= "" Windows Installer Package "" "
If Not PerUser Then
wxsString += " InstallScope= "" perMachine "" "
Else
wxsString += " InstallPrivileges= "" limited "" "
End If
wxsString += " /> " & vbCrLf
wxsString += " <Media Id= "" 1 "" Cabinet= "" rdp2msi.cab "" EmbedCab= "" yes "" /> " & vbCrLf
If Not PerUser Then wxsString += " <Property Id= "" AllUSERS "" Value= "" 1 "" /> " & vbCrLf
wxsString += " <Upgrade Id= "" $(var.ProductUpgradeCode) "" > " & vbCrLf
wxsString += " <UpgradeVersion Minimum= "" $(var.ProductVersion) "" OnlyDetect= "" yes "" Property= "" NEWERVERSIONDETECTED "" /> " & vbCrLf
wxsString += " <UpgradeVersion Minimum= "" 0.0.0 "" Maximum= "" $(var.ProductVersion) "" IncludeMinimum= "" yes "" IncludeMaximum= "" no "" " & vbCrLf
wxsString += " Property= "" OLDERVERSIONBEINGUPGRADED "" /> " & vbCrLf
wxsString += " </Upgrade> " & vbCrLf
wxsString += " <Condition Message= "" A newer version of this software is already installed. "" >NOT NEWERVERSIONDETECTED</Condition> " & vbCrLf
wxsString += " <Property Id= "" MstscProperty "" Value= "" mstsc.exe "" /> " & vbCrLf
wxsString += " <Directory Id= "" TARGETDIR "" Name= "" SourceDir "" > " & vbCrLf
If Not PerUser Then
wxsString += " <Directory Id= "" ProgramFilesFolder "" > " & vbCrLf
Else
wxsString += " <Directory Id= "" LocalAppDataFolder "" > " & vbCrLf
End If
wxsString += " <Directory Id= "" INSTALLDIR "" Name= "" RemotePackages "" > " & vbCrLf
wxsString += " <Component Id= "" ApplicationFiles "" Guid= "" $(var.AppFilesGuid) "" > " & vbCrLf
wxsString += " <File Id= "" rdpFile1 "" Source= "" $(var.ProductBaseFileName).rdp "" /> " & vbCrLf
If hasIcon Then wxsString += " <File Id= "" rdpIcon1 "" Source= "" $(var.ProductBaseFileName).ico "" /> " & vbCrLf
'# Begin filetype association code
If Not FlatFileTypes = " " Then
For Each FileType In FlatFileTypes . Replace ( " . " , " " ) . Split ( " , " )
wxsString += " <File Id= "" $(var.ProductProgID). " & FileType & " .ico "" Source= "" $(var.ProductBaseFileName). " & FileType & " .ico "" /> " & vbCrLf
wxsString += " <ProgId Id= "" remote.$(var.ProductProgID). " & FileType & " file "" Description= "" $(var.ProductName) " & FileType & " file "" Icon= "" $(var.ProductProgID). " & FileType & " .ico "" > " & vbCrLf
wxsString += " <Extension Id= "" " & FileType & " "" ContentType= "" application/ " & FileType & " "" > " & vbCrLf
wxsString += " <Verb Id= "" open "" Command= "" Open "" TargetProperty='MstscProperty' Argument='/REMOTEFILE: "" %1 "" "" [INSTALLDIR]$(var.ProductBaseFileName).rdp "" ' /> " & vbCrLf
wxsString += " </Extension> " & vbCrLf
wxsString += " </ProgId> " & vbCrLf
'wxsString += " <RegistryValue Root=""$(var.RegRoot)"" Key=""SOFTWARE\Classes\remote.$(var.ProductProgID)." & FileType & "file"" Name=""FriendlyTypeName"" Value=""$(var.ProductName) " & FileType & " file"" Type=""string"" />"
Next
End If
'# End FTA code
wxsString += " </Component> " & vbCrLf
wxsString += " </Directory> " & vbCrLf
wxsString += " </Directory> " & vbCrLf
If ShortcutInStart Then
wxsString += " <Directory Id= "" ProgramMenuFolder "" > " & vbCrLf
If ShortcutSubfolderInStart Then wxsString += " <Directory Id= "" ProgramMenuSubfolder "" Name= "" $(var.ProductName)$(var.ProductRemoteTag) "" > " & vbCrLf
wxsString += " <Component Id= "" ApplicationStartShortcuts "" Guid= "" $(var.AppStartShortcutsGuid) "" > " & vbCrLf
wxsString += " <Shortcut Id= "" rdpStartShortcut1 "" Name= "" $(var.ProductName)$(var.ProductRemoteTag) "" Description= "" $(var.ProductName)$(var.ProductRemoteTag) "" " & vbCrLf
wxsString += " Target= "" [INSTALLDIR]$(var.ProductBaseFileName).rdp "" WorkingDirectory= "" INSTALLDIR "" "
If hasIcon Then
wxsString += " Icon= "" rdpStartIcon.rdp "" IconIndex= "" 0 "" > " & vbCrLf
wxsString += " <Icon Id= "" rdpStartIcon.rdp "" SourceFile= "" $(var.ProductBaseFileName).ico "" /> " & vbCrLf
wxsString += " </Shortcut> " & vbCrLf
Else
wxsString += " /> " & vbCrLf
End If
wxsString += " <RegistryValue Root= "" $(var.RegRoot) "" Key= "" Software\RDP2MSI\$(var.ProductName) "" " & vbCrLf
wxsString += " Name= "" installed "" Type= "" integer "" Value= "" 1 "" KeyPath= "" yes "" /> " & vbCrLf
wxsString += " <RemoveFolder Id= "" ProgramMenuSubfolder "" On= "" uninstall "" /> " & vbCrLf
wxsString += " </Component> " & vbCrLf
If ShortcutSubfolderInStart Then wxsString += " </Directory> " & vbCrLf
wxsString += " </Directory> " & vbCrLf
End If
If ShortcutOnDesktop Then
wxsString += " <Directory Id= "" DesktopFolder "" > " & vbCrLf
wxsString += " <Component Id= "" ApplicationDesktopShortcuts "" Guid= "" $(var.AppDeskShortcutsGuid) "" > " & vbCrLf
wxsString += " <Shortcut Id= "" rdpDesktopShortcut1 "" Name= "" $(var.ProductName)$(var.ProductRemoteTag) "" Description= "" $(var.ProductName)$(var.ProductRemoteTag) "" " & vbCrLf
wxsString += " Target= "" [INSTALLDIR]$(var.ProductBaseFileName).rdp "" WorkingDirectory= "" INSTALLDIR "" "
If hasIcon Then
wxsString += " Icon= "" rdpDeskIcon.rdp "" IconIndex= "" 0 "" > " & vbCrLf
wxsString += " <Icon Id= "" rdpDeskIcon.rdp "" SourceFile= "" $(var.ProductBaseFileName).ico "" /> " & vbCrLf
wxsString += " </Shortcut> " & vbCrLf
Else
wxsString += " /> " & vbCrLf
End If
wxsString += " <RegistryValue Root= "" $(var.RegRoot) "" Key= "" Software\RDP2MSI\$(var.ProductName) "" " & vbCrLf
wxsString += " Name= "" installed "" Type= "" integer "" Value= "" 1 "" KeyPath= "" yes "" /> " & vbCrLf
wxsString += " </Component> " & vbCrLf
wxsString += " </Directory> " & vbCrLf
End If
wxsString += " </Directory> " & vbCrLf
wxsString += " <InstallExecuteSequence> " & vbCrLf
wxsString += " <RemoveExistingProducts After= "" InstallValidate "" /> " & vbCrLf
wxsString += " </InstallExecuteSequence> " & vbCrLf
wxsString += " "
wxsString += " <Feature Id= "" DefaultFeature "" Level= "" 1 "" > " & vbCrLf
wxsString += " <ComponentRef Id= "" ApplicationFiles "" /> " & vbCrLf
If ShortcutInStart Then wxsString += " <ComponentRef Id= "" ApplicationStartShortcuts "" /> " & vbCrLf
If ShortcutOnDesktop Then wxsString += " <ComponentRef Id= "" ApplicationDesktopShortcuts "" /> " & vbCrLf
wxsString += " </Feature> " & vbCrLf
If hasIcon Then
wxsString += " <Icon Id= "" rdpARPIcon.rdp "" SourceFile= "" $(var.ProductBaseFileName).ico "" /> " & vbCrLf
wxsString += " <Property Id= "" ARPPRODUCTICON "" Value= "" rdpARPIcon.rdp "" /> " & vbCrLf
End If
wxsString += " </Product> " & vbCrLf
wxsString += " </Wix> " & vbCrLf
Return wxsString
End Function
Public Function ReadRDPProperty ( rdpProperty As String ) As String
Dim rdpFileLines = Split ( rdpFileContents , vbLf )
Dim rdpValue = " "
For Each rdpLine In rdpFileLines
rdpLine = Replace ( rdpLine , vbCr , " " )
rdpLine = Replace ( rdpLine , " | " , " " )
Dim rdpLineSplit = Split ( rdpLine , " : " , 3 )
If rdpLineSplit ( 0 ) = rdpProperty Then
rdpValue = rdpLineSplit ( 2 )
End If
Next
Return rdpValue
End Function
Private Function GenerateGUIDfromString ( TheString As String )
Dim TheHash = getMD5Hash ( TheString )
Dim MyGuid As Guid = New Guid ( TheHash )
Return MyGuid . ToString
End Function
Private Function getMD5Hash ( ByVal strToHash As String ) As String
Dim md5Obj As New System . Security . Cryptography . MD5CryptoServiceProvider ( )
Dim bytesToHash ( ) As Byte = System . Text . Encoding . ASCII . GetBytes ( strToHash )
bytesToHash = md5Obj . ComputeHash ( bytesToHash )
Dim strResult As String = " "
Dim b As Byte
For Each b In bytesToHash
strResult += b . ToString ( " x2 " )
Next
Return strResult
End Function
Private Function RunWait ( App As String , Parameters As String ) As Integer
Dim proc As New Process
proc . StartInfo . CreateNoWindow = True
proc . StartInfo . WindowStyle = ProcessWindowStyle . Hidden
proc . StartInfo . FileName = App
proc . StartInfo . Arguments = Parameters
proc . Start ( )
proc . WaitForExit ( )
Return proc . ExitCode
End Function
End Class