VGnet.dk - VBA og Windows

Koden anvendes helt på eget ansvar!

Indhold:

Skaf navnet på en eksisterende mappe

Function SkafMappeNavn(Optional medd) As String
' Dialogboks til at klikke frem til en mappe
  Dim bInfo As BROWSEINFO
  Dim sti As String
  Dim r As Long, x As Long, Pos As Integer
  ' Startsted Skrivebordet
  bInfo.pidlRoot = 0&
  ' Dialogboksens titel
  If IsMissing(medd) Then
    bInfo.lpszTitle = "Vælg en mappe"
  Else
    bInfo.lpszTitle = medd
  End If
  ' Type af mappe, der skal skaffes
  bInfo.ulFlags = &H1
  ' Vis dialogboksen
  x = SHBrowseForFolder(bInfo)
  ' Sorter resultatet
  sti = Space$(512)
  r = SHGetPathFromIDList(ByVal x, ByVal sti)
  If r Then
    Pos = InStr(sti, Chr$(0))
    SkafMappeNavn = Left(sti, Pos - 1)
  Else
    SkafMappeNavn = ""
  End If
End Function

Øverst i modulet skal følgende erklæringer være:

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszpath As String) As Long
' Erklæring til SkafMappeNavn
 
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
' Erklæring til SkafMappeNavn

Public Type BROWSEINFO
' Type til SkafMappeNavn
  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

Kør i en Shell, der venter på afviklingen

Sub KoerShell(Program As String, Fokus)
' Kører en proces med Shell, men venter, til den er afsluttet.
  Dim TaskID As Long
  Dim hProc As Long
  Dim lExitCode As Long
  Const ACCESS_TYPE = &H400
  Const STILL_ACTIVE = &H103
  TaskID = Shell(Program, Fokus)
  hProc = OpenProcess(ACCESS_TYPE, False, TaskID)
  If Err <> 0 Then
    MsgBox "Kan ikke starte " & Program, vbCritical, "Fejl"
    Exit Sub
  End If
  Do
    GetExitCodeProcess hProc, lExitCode
    DoEvents
  Loop While lExitCode = STILL_ACTIVE
End Sub

Øverst i modulet skal følgende erklæringer være:

Declare Function OpenProcess Lib "kernel32" _
  (ByVal dwDesiredAccess As Long, _
  ByVal bInheritHandle As Long, _
  ByVal dwProcessID As Long) As Long
' Erklæring til KoerShell

Declare Function GetExitCodeProcess Lib "kernel32" _
  (ByVal hProcess As Long, _
  lpExitCode As Long) As Long
' Erklæring til KoerShell

Navnet på Windows' sti

Function WindowsSti() As String
' Viser Windows' placering
  Dim WinSti As String
  WinSti = Space(255)
  WindowsSti = Left(WinSti, GetWindowsDirectoryA(WinSti, Len(WinSti)))
End Function

Øverst i modulet skal følgende erklæring være:

Declare Function GetWindowsDirectoryA Lib "kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
' Erklæring til WindowsSti

Siden er oprettet 25-12-2006 og sidst opdateret 14-01-2007 22:53.

█