[WIN7] Startmenü

GPI · Beitrag von **GPI** » 23.09.2010 15:07

Wer schon immer das Startmenü als PopMenü darstellen wollte, kann ja mal hier schaun:

file$="C:\ProgramData\Microsoft\Windows\Start Menu\"

Procedure.s GetLinkIcon(ShellLink.s, *nr)
  ;LinkFile.s=Str(Len(ShellLink)*2)
  ;MultiByteToWideChar_(#CP_ACP, 0, ShellLink, -1, @LinkFile, Len(ShellLink)) ;We need a WideChar version of the ShellLink.s
  
  Buf.s = Space(1024)
  Hotkey.w = 0
  
  Result = 0
  CoInitialize_(0)
  If CoCreateInstance_(?CLSID_ShellLink,0,1,?IID_IShellLink,@psl.IShellLinkA) >= 0
    If psl\QueryInterface(?IID_IPersistFile, @ppf.IPersistFile) >= 0
      If ppf\Load(shelllink,0) >= 0 ;Icon loaded?
        ;Get the icon file and the icon index
        psl\GetIconLocation(@Buf, 1024, *nr)
        If buf=""
          psl\GetPath(Buf, 1024, 0, 4)
        EndIf
      EndIf
      ppf\Release()
    EndIf
    psl\Release()
  EndIf
  CoUninitialize_()
  
  
  
  ProcedureReturn buf
  
  
  
  DataSection
    CLSID_ShellLink:
    ; 00021401-0000-0000-C000-000000000046
    Data.l $00021401
    Data.w $0000,$0000
    Data.b $C0,$00,$00,$00,$00,$00,$00,$46
    IID_IShellLink:
    ; DEFINE_SHLGUID(IID_IShellLinkA,         0x000214EEL, 0, 0)
    ; C000-000000000046
    Data.l $000214EE
    Data.w $0000,$0000
    Data.b $C0,$00,$00,$00,$00,$00,$00,$46
    IID_IPersistFile:
    ; 0000010b-0000-0000-C000-000000000046
    Data.l $0000010b
    Data.w $0000,$0000
    Data.b $C0,$00,$00,$00,$00,$00,$00,$46
  EndDataSection
  
EndProcedure


Procedure LoadIcon(File$,b.l=0)
  If b=0
    ProcedureReturn ExtractAssociatedIcon_(GetModuleHandle_(0),file$,@b)
  Else  
    
    ProcedureReturn ExtractIcon_(GetModuleHandle_(0),file$,b)
  EndIf
EndProcedure  
Procedure FreeIcon(icon)
  ProcedureReturn DestroyIcon_(hIcon)
EndProcedure

Structure IconListe
  name.s
  icon.i
EndStructure

NewList Dateien.iconliste()
Global menu_entry=0

Procedure.s FilePart(a$)
  ProcedureReturn Left(a$,Len(a$)-FindString(ReverseString(a$),".",0))
EndProcedure

Procedure ScanDir(List Dateien.iconListe(),pfad$)
  dir=ExamineDirectory(#PB_Any,pfad$,"*.*")
  While NextDirectoryEntry(dir)
    file$=DirectoryEntryName(dir)
    ;Debug file$
    If DirectoryEntryType(dir)=#PB_DirectoryEntry_Directory 
      If file$<>"." And file$<>".."
        OpenSubMenu(file$)
        scandir(dateien(),pfad$+file$+"\")
        CloseSubMenu()
      EndIf
    EndIf
  Wend
  
  dir=ExamineDirectory(#PB_Any,pfad$,"*.*")
  While NextDirectoryEntry(dir)
    file$=DirectoryEntryName(dir)
    ;Debug file$
    If DirectoryEntryType(dir)=#PB_DirectoryEntry_File And LCase(file$)<>"desktop.ini"
      AddElement(dateien())
      dateien()\name=pfad$+file$
      ;Debug file$
      If UCase(GetExtensionPart(file$))="LNK" 
        icon$=GetLinkIcon(pfad$+file$,@a.l)
        dateien()\icon=loadicon(icon$,a)
        If dateien()\icon=0
          Debug "fehler:"+file$
        EndIf        
      ElseIf UCase(GetExtensionPart(file$))="URL"
        icon$="":iconnr=0
        
        If ReadFile(1,pfad$+file$)
          While Not Eof(1)
            a$=ReadString(1)
            ;Debug a$
            Select UCase(StringField(a$,1,"="))
              Case "ICONFILE":icon$=StringField(a$,2,"=")
              Case "ICONINDEX":iconnr=Val(StringField(a$,2,"="))
            EndSelect
            
          Wend
          CloseFile(1)
        EndIf
        If icon$
          dateien()\icon=loadicon(icon$,iconnr)
        Else
          dateien()\icon=loadicon(pfad$+file$)
        EndIf
        
      Else  
        dateien()\icon=loadicon(pfad$+file$)
      EndIf  
      MenuItem(menu_entry,filepart(file$),dateien()\icon)
      menu_entry+1
      
    EndIf
  Wend
  
EndProcedure

CreatePopupImageMenu(0)
scandir(dateien(),file$)



OpenWindow(0,0,0,100,100,"test",#PB_Window_SystemMenu)
DisplayPopupMenu(0,WindowID(0))

Repeat : Until WaitWindowEvent()=#PB_Event_CloseWindow

ForEach dateien()
  freeicon(dateien()\icon)
Next

Beitrag von **bobobo** » 23.09.2010 16:08

Was aber ziemlich schlechter Code ist. Zum einen läufts so unter Linux nicht und zum anderen ist das ganze undokumentiert.

(hihi : ich konnte nicht widerstehen)

GPI · Beitrag von **GPI** » 23.09.2010 16:13

Deshalb steht auch groß [WIN7] in Titel - Für linux und iJünger ungeeignet

Aber ich merk gerade, es listet nur das Startmenü für alle Benutzer, nicht für den einzelnen User. Man müßte vorher 2 Verzeichnisse synchronisieren.

GPI · Beitrag von **GPI** » 23.09.2010 21:59

Variante zwei

Code: Alles auswählen

file$="C:\ProgramData\Microsoft\Windows\Start Menu\"
;file$="C:\Program Files\uTorrent\uTorrent.exe"

Procedure.s GetLinkIcon(ShellLink.s, *nr)
  ;LinkFile.s=Str(Len(ShellLink)*2)
  ;MultiByteToWideChar_(#CP_ACP, 0, ShellLink, -1, @LinkFile, Len(ShellLink)) ;We need a WideChar version of the ShellLink.s
  
  Buf.s = Space(1024)
  Hotkey.w = 0
  
  Result = 0
  CoInitialize_(0)
  If CoCreateInstance_(?CLSID_ShellLink,0,1,?IID_IShellLink,@psl.IShellLinkA) >= 0
    If psl\QueryInterface(?IID_IPersistFile, @ppf.IPersistFile) >= 0
      If ppf\Load(shelllink,0) >= 0 ;Icon loaded?
        ;Get the icon file and the icon index
        psl\GetIconLocation(@Buf, 1024, *nr)
        If buf=""
          psl\GetPath(Buf, 1024, 0, 4)
        EndIf
      EndIf
      ppf\Release()
    EndIf
    psl\Release()
  EndIf
  CoUninitialize_()
  
  
  
  ProcedureReturn buf
  
  
  
  DataSection
    CLSID_ShellLink:
    ; 00021401-0000-0000-C000-000000000046
    Data.l $00021401
    Data.w $0000,$0000
    Data.b $C0,$00,$00,$00,$00,$00,$00,$46
    IID_IShellLink:
    ; DEFINE_SHLGUID(IID_IShellLinkA,         0x000214EEL, 0, 0)
    ; C000-000000000046
    Data.l $000214EE
    Data.w $0000,$0000
    Data.b $C0,$00,$00,$00,$00,$00,$00,$46
    IID_IPersistFile:
    ; 0000010b-0000-0000-C000-000000000046
    Data.l $0000010b
    Data.w $0000,$0000
    Data.b $C0,$00,$00,$00,$00,$00,$00,$46
  EndDataSection
  
EndProcedure

Procedure LoadIcon(File$,b.l=0)
  If b=0
    ProcedureReturn ExtractAssociatedIcon_(GetModuleHandle_(0),file$,@b)
  Else  
    
    ProcedureReturn ExtractIcon_(GetModuleHandle_(0),file$,b)
  EndIf
EndProcedure  
Procedure FreeIcon(icon)
  ProcedureReturn DestroyIcon_(hIcon)
EndProcedure

Structure dateien
  name.s
  addpfad.s
  basispfad.s
  type.l
  iconname.s
  iconnr.l
  icon.l
  menuitem.l
EndStructure

Global NewList dateien.dateien()
Procedure examineDateien(folder.s)
  ResetList(dateien())
EndProcedure
Procedure nextDateien(folder.s)
  folder=UCase(folder)
  Repeat
    a=NextElement(dateien())
    If a=0
      Break
    ElseIf UCase(dateien()\addpfad)=folder
      Break
    EndIf
  ForEver
  ProcedureReturn a
EndProcedure


Procedure findEntry(addpfad.s,name.s)
  addpfad=UCase(addpfad)
  name=UCase(name)
  ok=#False
  ForEach dateien()
    If UCase(dateien()\name)=name And UCase(dateien()\addpfad)=addpfad
      ok=#True
      Break  
    EndIf  
  Next
  ProcedureReturn ok
EndProcedure

Procedure Addfiles(basispfad.s,addpfad.s)
  dir=ExamineDirectory(#PB_Any,basispfad+"\"+addpfad,"*.*")
  
  ;Debug basispfad+"\"+addpfad
  ;Debug dir
  If dir
    While NextDirectoryEntry(dir)
      name$=DirectoryEntryName(dir)
      ;Debug name$
      Select DirectoryEntryType(dir)
        Case #PB_DirectoryEntry_Directory
          If name$<>"." And name$<>".."
            If findEntry(addpfad,name$)=#False
              AddElement(dateien())
              dateien()\name=name$
              dateien()\addpfad=addpfad
              dateien()\basispfad=basispfad
              dateien()\type=#PB_DirectoryEntry_Directory
            EndIf
            
            addfiles(basispfad,addpfad+name$+"\")
            
          EndIf
        Case #PB_DirectoryEntry_File
          If UCase(name$)<>"DESKTOP.INI"
            If findEntry(addpfad,name$)=#False
              AddElement(dateien())
              dateien()\name=name$
              dateien()\addpfad=addpfad
              dateien()\basispfad=basispfad
              dateien()\type=#PB_DirectoryEntry_File
            EndIf
          EndIf
      EndSelect
      
    Wend
    
  EndIf
EndProcedure

Global menu_entry=1

Procedure.s FilePart(a$)
  ProcedureReturn Left(a$,Len(a$)-FindString(ReverseString(a$),".",0))
EndProcedure

Procedure ScanDir(pfad$)
  examineDateien(pfad$)
  ;Debug "scan:"+pfad$
  While nextDateien(pfad$)
    file$=dateien()\name
    ;Debug file$
    Select dateien()\type
      Case #PB_DirectoryEntry_Directory 
        OpenSubMenu(file$)
        *cur=@dateien()
        scandir(pfad$+file$+"\")
        ChangeCurrentElement(dateien(),*cur)
        CloseSubMenu()
        
      Case #PB_DirectoryEntry_File 
        ;Debug dateien()\name
        If UCase(GetExtensionPart(file$))="LNK" 
          icon$=GetLinkIcon(dateien()\basispfad+"\"+pfad$+file$,@a.l)
          dateien()\icon=loadicon(icon$,a)
          dateien()\iconname=icon$
          dateien()\iconnr=a
        ElseIf UCase(GetExtensionPart(file$))="URL"
          icon$="":iconnr=0
          
          If ReadFile(1,pfad$+file$)
            While Not Eof(1)
              a$=ReadString(1)
              ;Debug a$
              Select UCase(StringField(a$,1,"="))
                Case "ICONFILE":icon$=StringField(a$,2,"=")
                Case "ICONINDEX":iconnr=Val(StringField(a$,2,"="))
              EndSelect
              
            Wend
            CloseFile(1)
          EndIf
          If icon$
            dateien()\icon=loadicon(icon$,iconnr)
            dateien()\iconname=icon$
            dateien()\iconnr=iconnr
          Else
            dateien()\icon=loadicon(dateien()\basispfad+"\"+pfad$+file$)
            dateien()\iconname=dateien()\basispfad+"\"+pfad$+file$
            dateien()\iconnr=0
          EndIf
          
        Else  
          dateien()\icon=loadicon(dateien()\basispfad+"\"+pfad$+file$)
          dateien()\iconname=dateien()\basispfad+"\"+pfad$+file$
          dateien()\iconnr=0
        EndIf  
        MenuItem(menu_entry,filepart(file$),dateien()\icon)
        dateien()\menuitem=menu_entry
        menu_entry+1
    EndSelect    
  Wend
  
EndProcedure



;Einlesen
file$="C:\ProgramData\Microsoft\Windows\Start Menu"
addfiles(file$,"")

file$=GetEnvironmentVariable("USERPROFILE")+"\AppData\Roaming\Microsoft\Windows\Start Menu"
addfiles(file$,"")

count=ListSize(dateien())-1

;sortieren
For i=0 To count-1
  SelectElement(dateien(),i)
  name$=UCase(dateien()\name)
  addpfad.s=UCase(dateien()\addpfad)
  type=dateien()\type
  *x=@dateien()
  *org=@dateien()
  
  While NextElement(dateien())
    ;SelectElement(dateien(),a)
    swapit=#False
    ap.s=UCase(dateien()\addpfad)
    n.s=UCase(dateien()\name)
    
    If ap<addpfad
      
      swapit=#True
    ElseIf ap=addpfad 
      If  dateien()\type=#PB_DirectoryEntry_Directory And type=#PB_DirectoryEntry_File
        swapit=#True
      ElseIf dateien()\type=type And n<name$
        swapit=#True
      EndIf
    EndIf
    
    If swapit
      name$=n
      addpfad.s=ap
      type=dateien()\type
      *x=@dateien()
    EndIf
  Wend
  If *x<>*org
    SwapElements(dateien(),*org,*x)
  EndIf   
Next



CreatePopupImageMenu(0)
scandir("")
;readicons(dateien())


OpenWindow(0,0,0,100,100,"test",#PB_Window_SystemMenu)
DisplayPopupMenu(0,WindowID(0))



Repeat : Until WaitWindowEvent()=#PB_Event_CloseWindow

ForEach dateien()
  If dateien()\icon
    freeicon(dateien()\icon)
  EndIf
Next

Diesmal werden sowohl das spezifische als das allgemeine Startmenü zusammengefasst.

Beitrag von **RSBasic** » 24.09.2010 16:48

Hallo GPI,

schöner Code.

Da ich das klassische Startmenü besser finde, als ab Vista dieses "moderne" Startenü, und da bei Win7 sowas nicht mehr gibt, habe ich auch ein Programm dafür geschrieben und zwar: http://www.purebasic.fr/german/viewtopi ... 11&t=20513
Aber bei meiner Anwendung war bzw. ist es so, dass zuerst die Dateien und dann die Verzeichnisse angezeigt werden.
Was umgekehrt natürlich besser ist, wie bei deinem Beispielcode.
So sollte es auch sein, nur ich hab es damals, als ich meine Anwendung geschrieben habe, nicht richtig geschafft, die Routinen zu vertauchen.

PureBoard

[WIN7] Startmenü

[WIN7] Startmenü

Re: [WIN7] Startmenü

Re: [WIN7] Startmenü

Re: [WIN7] Startmenü

Re: [WIN7] Startmenü