Option Compare Database
Option Explicit

Private Declare Function api32_GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
                              (ByVal lpBuffer As String, nSize As Long) As Long

Public Function smsGenShortCut(ByVal vstrObjectName As String, _
                               Optional ByVal vstrShortCutFilePath As String = "", _
                               Optional ByVal vstrShortCutFileName As String = "", _
                               Optional ByVal vstrSourceMDBFullPath As String = "") As String
'*+
'
' Public domain. MS Access 97.
'
' Authors:
'       Shamil Salakhetdinov , 29/01/98
'       e-mail: shamil@marta.darts.spb.ru
'
' Purpose:
'       Generate shortcut file for given database object (shortcut file format spec
'         is unknown for author)
' Arguments:
'       vstrObjectName       - Database object name
'       vstrShortCutFilePath - Filepath of shortcut file to generate. Optional. If is missing -
'                              filepath of the object's database is used as shortcut file path
'       vstrShortCutFileName - Filename (no fileext!) of shortcut file to generate. Optional. If is
'                              missing vstrObjectName is used as shortcut filename
'       vstrSourceMDBFullPath - vstrObjectName's database fullpath. Optional. If is missing
'                              CodeDB().Name is used
'
' Returns:
'       Fullpath of the generated shortcut file - success
'       "" - failure
'
' Examples:
'       smsGenShortCut "frmMyForm"
'       smsGenShortCut "frmMyForm","c:\MyDir\"
'       smsGenShortCut "frmMyForm","c:\MyDir\","Shortcut to MyForm"
'       smsGenShortCut "frmMyForm",,"Shortcut to MyForm","c:\MyDir\Acc97\MyTst.mde"
'
' Revisions:
'
    On Error GoTo smsGenShortCut_Err
    
    smsGenShortCut = ""
   
    Dim dbs As Database
    Dim con As Container
    Dim doc As Document
    Dim tdf As TableDef
    
    Dim blnDocFound As Boolean
    Dim strObjectType As String
    Dim strFileExt As String
    Dim varIconId As Variant
    
    Dim intFn As Integer
    Dim strDBFileFullPath As String
    Dim strDBFilePath As String
    Dim strDBFileNameExt As String
    Dim i As Integer
    Dim strShortCutFileFullPath As String
        
    
    blnDocFound = False
    strObjectType = ""
    
    If vstrSourceMDBFullPath = "" Then
        Set dbs = CodeDb()
    Else
        Set dbs = DBEngine(0).OpenDatabase(vstrSourceMDBFullPath)
    End If
    
    For Each con In dbs.Containers
        For Each doc In con.Documents
          If doc.Name = vstrObjectName Then
             blnDocFound = True
             Exit For
          End If
        Next
        If blnDocFound Then Exit For
    Next
    
    If blnDocFound Then
        Select Case con.Name
        Case "Tables":
             On Error Resume Next
             Set tdf = dbs.TableDefs(vstrObjectName)
             If Err = 0 Then
                strObjectType = "Table"
                strFileExt = "MAT"
                varIconId = 274
             Else
                Err.Clear
                strObjectType = "Query"
                strFileExt = "MAQ"
                varIconId = 280
            End If
             On Error GoTo 0
        Case "Forms":
             strObjectType = "Form"
             strFileExt = "MAF"
             varIconId = 263
        Case "Reports":
             strObjectType = "Report"
             strFileExt = "MAR"
             varIconId = 264
        Case "Scripts":
             strObjectType = "Macro"
             strFileExt = "MAM"
             varIconId = 265
        Case "Modules":
             strObjectType = "Module"
             strFileExt = "MAD"
             varIconId = 266
        Case Else
        End Select
    Else
    End If

   
    If strObjectType <> "" Then
    
        If vstrShortCutFileName = "" Then
            vstrShortCutFileName = vstrObjectName
        End If
        
        strDBFileFullPath = dbs.Name
        For i = Len(strDBFileFullPath) To 1 Step -1
            If Mid(strDBFileFullPath, i, 1) = "\" Then
                strDBFilePath = Left(strDBFileFullPath, i)
                strDBFileNameExt = Mid(strDBFileFullPath, i + 1)
                Exit For
            End If
        Next
        
        If vstrShortCutFilePath <> "" Then
            If Right(vstrShortCutFilePath, 1) <> "\" Then
                vstrShortCutFilePath = vstrShortCutFilePath & "\"
            End If
        Else
            vstrShortCutFilePath = strDBFilePath
        End If
        
        strShortCutFileFullPath = vstrShortCutFilePath & vstrShortCutFileName & "." & strFileExt
        
        intFn = FreeFile
        Open strShortCutFileFullPath For Output Access Write As #intFn
        
        '[Shortcut Properties]
        Print #intFn, "[Shortcut Properties]"
        'AccessShortcutVersion = 1
        Print #intFn, "AccessShortCutVersion = 1"
        'DatabaseName = MyDatabase.MDB
        Print #intFn, "DatabaseName = " & strDBFileNameExt & vbCr
        'ObjectName = MyObjectName
        Print #intFn, "ObjectName = " & vstrObjectName & vbCr
        'ObjectType = Form
        Print #intFn, "ObjectType = " & strObjectType & vbCr
        'Computer = MyComputer
        Print #intFn, "Computer = " & smsGetComputerName() & vbCr
        'DatabasePath=C:\MyDir\MyApp.mde
        Print #intFn, "DatabasePath = " & strDBFileFullPath & vbCr
        'EnableRemote = 0
        Print #intFn, "EnableRemote = 0" & vbCr
        'CreationTime= 1bd0c569308f340 ' format ???
        Print #intFn, "CreationTime = 1bd0c569308f340" & vbCr
        'Icon = 263
        Print #intFn, "Icon = " & varIconId & vbCr
        
        Close #intFn
    End If
    
    smsGenShortCut = strShortCutFileFullPath
    
smsGenShortCut_Exit:
    Exit Function
smsGenShortCut_Err:
    MsgBox "smsGenShortCut:" & Err & " - " & Err.Description, vbCritical + vbOKOnly
    Resume smsGenShortCut_Exit
End Function

Private Function smsGetComputerName() As String
    On Error Resume Next
    
    Dim strComputerName As String * 512
    Dim lngBufLen As Long
    Dim lngRet As Long
    
    lngBufLen = 503
    strComputerName = String(512, 0)
    lngRet = api32_GetComputerName(strComputerName, lngBufLen)
    If lngRet <> 0 Then
        smsGetComputerName = Left(strComputerName, lngBufLen)
    Else
        smsGetComputerName = ""
    End If
End Function