basfunction.bas

vb默认工程创建器

Attribute VB_Name = "basFunction"
Option Explicit

Private Const MAX_LEN = 200
'字符串最大长度
Private Const DESKTOP = &H0&
'桌面
Private Const PROGRAMS = &H2&   '程序集
Private Const STARTUP = &H7&   '启动
Private Const STARTMENU = &HB&   '开始菜单
Private Const MYDOCUMENTS = &H5&  'My Documents
Private Const MYFAVORITES = &H6&  'My Favorites
Private Const RECENT = &H8&  '最近打开的文件

Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public NowPath As String
Public ProjectName As String

Public Function GetDesktopPath() As String
   Dim s As String * MAX_LEN   '存放结果的固定长度的字符串
   Dim Length As Long
   '字符串的实际长度
   Dim pidl As Long
   Dim txtWinPath As String
   Dim txtSystemPath As String
   '某特殊目录在特殊目录列表中的位置
   '获得Windows目录
   Length = GetWindowsDirectory(s, MAX_LEN)
   txtWinPath = Left(s, Length)
   '获得System目录
   Length = GetSystemDirectory(s, MAX_LEN)
   txtSystemPath = Left(s, Length)
   '获得DeskTop目录,为获得其他特殊目录
   '只需改变SHGetSpecialFolderLocation的第二个参数即可
   Call SHGetSpecialFolderLocation(0, DESKTOP, pidl)
   Call SHGetPathFromIDList(pidl, s)
   GetDesktopPath = Left(s, InStr(s, Chr(0)) - 1)
End Function

'写文本文件
Public Sub WriteTextFile(FilePathAndName As String, FileDataStr As String)
   Dim fso
   Dim a
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set a = fso.CreateTextFile(FilePathAndName, True)
   a.Write (FileDataStr)
   a.Close
End Sub


'创建Form文本 frmMain.frm
Public Function VBForm1(ProjectName As String) As String
   Dim TmpStr As String
   TmpStr = "VERSION 5.00" & vbCrLf
   TmpStr = TmpStr & "Begin VB.Form frmMain " & vbCrLf
   TmpStr = TmpStr & "   Caption  "
   TmpStr = TmpStr & "       =   " & Chr(34) & ProjectName & Chr(34) & vbCrLf
   TmpStr = TmpStr & "   ClientHeight    ="
   TmpStr = TmpStr & "   4230" & vbCrLf
   TmpStr = TmpStr & "   ClientLeft      =   4320" & vbCrLf
   TmpStr = TmpStr & "   ClientTop"
   TmpStr = TmpStr & "       =   3540" & vbCrLf
   TmpStr = TmpStr & "   ClientWidth     =   7650" & vbCrLf
   TmpStr = TmpStr & "   L"
   TmpStr = TmpStr & "inkTopic       =   " & Chr(34) & "frmMain" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "   ScaleHeight     ="
   TmpStr = TmpStr & "   4230" & vbCrLf
   TmpStr = TmpStr & "   ScaleWidth      =   7650" & vbCrLf
   TmpStr = TmpStr & "End" & vbCrLf
   TmpStr = TmpStr & "Attribu"
   TmpStr = TmpStr & "te VB_Name = " & Chr(34) & "frmMain" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Attribute VB_GlobalNameSpa"
   TmpStr = TmpStr & "ce = False" & vbCrLf
   TmpStr = TmpStr & "Attribute VB_Creatable = False" & vbCrLf
   TmpStr = TmpStr & "Attrib"
   TmpStr = TmpStr & "ute VB_PredeclaredId = True" & vbCrLf
   TmpStr = TmpStr & "Attribute VB_Exposed "
   TmpStr = TmpStr & "= False" & vbCrLf
   TmpStr = TmpStr & "Option Explicit" & vbCrLf
   TmpStr = TmpStr & vbCrLf
   VBForm1 = TmpStr
End Function

'MSSCCPRJ.SCC
Public Function VBSCC(ProjectName As String) As String
   Dim TmpStr As String
   TmpStr = "[SCC]" & vbCrLf
   TmpStr = TmpStr & "SCC=This is a source code control file" & vbCrLf
   TmpStr = TmpStr & "[" & ProjectName & "."
   TmpStr = TmpStr & "vbp]" & vbCrLf
   TmpStr = TmpStr & "SCC_Project_Name=this project "
   TmpStr = TmpStr & "is not under source code control" & vbCrLf
   TmpStr = TmpStr & "SCC_Aux_Path=<Th"
   TmpStr = TmpStr & "is is an empty string for the mssccprj.scc file>" & vbCrLf
   VBSCC = TmpStr
End Function

'VB默认工程创建器.vbp
Public Function VBVBP(ProjectName As String, Optional basName As String = "basFunction") As String
   Dim TmpStr As String
   TmpStr = "Type=Exe" & vbCrLf
   TmpStr = TmpStr & "Reference=*\G{00020430-0000-0000-C000-00"
   TmpStr = TmpStr & "0000000046}#2.0#0#C:\WINDOWS\system32\StdOle2.tlb#"
   TmpStr = TmpStr & "OLE Automation" & vbCrLf
   TmpStr = TmpStr & "Object={F9043C88-F6F2-101A-A3C9-08"
   TmpStr = TmpStr & "002B2F49FB}#1.2#0; COMDLG32.OCX" & vbCrLf
   TmpStr = TmpStr & "Module=" & basName & ";"
   TmpStr = TmpStr & " " & basName & ".bas" & vbCrLf
   TmpStr = TmpStr & "Form=frmMain.frm" & vbCrLf
   TmpStr = TmpStr & "Startup=" & Chr(34) & "frm"
   TmpStr = TmpStr & "Main" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "HelpFile=" & Chr(34) & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Command32=" & Chr(34) & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Name=" & Chr(34) & ProjectName & Chr(34)
   TmpStr = TmpStr & vbCrLf
   TmpStr = TmpStr & "HelpContextID=" & Chr(34) & "0" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "CompatibleMode=" & Chr(34) & "0" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Maj"
   TmpStr = TmpStr & "orVer=1" & vbCrLf
   TmpStr = TmpStr & "MinorVer=0" & vbCrLf
   TmpStr = TmpStr & "RevisionVer=0" & vbCrLf
   TmpStr = TmpStr & "AutoIncrementV"
   TmpStr = TmpStr & "er=0" & vbCrLf
   TmpStr = TmpStr & "ServerSupportFiles=0" & vbCrLf
   TmpStr = TmpStr & "VersionCompanyName=" & Chr(34) & "微软"
   TmpStr = TmpStr & "中国" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "CompilationType=0" & vbCrLf
   TmpStr = TmpStr & "OptimizationType=0" & vbCrLf
   TmpStr = TmpStr & "FavorP"
   TmpStr = TmpStr & "entiumPro(tm)=0" & vbCrLf
   TmpStr = TmpStr & "CodeViewDebugInfo=0" & vbCrLf
   TmpStr = TmpStr & "NoAliasing=0"
   TmpStr = TmpStr & vbCrLf
   TmpStr = TmpStr & "BoundsCheck=0" & vbCrLf
   TmpStr = TmpStr & "OverflowCheck=0" & vbCrLf
   TmpStr = TmpStr & "FlPointCheck=0" & vbCrLf
   TmpStr = TmpStr & "F"
   TmpStr = TmpStr & "DIVCheck=0" & vbCrLf
   TmpStr = TmpStr & "UnroundedFP=0" & vbCrLf
   TmpStr = TmpStr & "StartMode=0" & vbCrLf
   TmpStr = TmpStr & "Unattende"
   TmpStr = TmpStr & "d=0" & vbCrLf
   TmpStr = TmpStr & "Retained=0" & vbCrLf
   TmpStr = TmpStr & "ThreadPerObject=0" & vbCrLf
   TmpStr = TmpStr & "MaxNumberOfThr"
   TmpStr = TmpStr & "eads=1" & vbCrLf
   TmpStr = TmpStr & vbCrLf
   TmpStr = TmpStr & "[MS Transaction Server]" & vbCrLf
   TmpStr = TmpStr & "AutoRefresh=1" & vbCrLf
   VBVBP = TmpStr
End Function



'VB默认工程创建器.vbw
Public Function VBVBW(Optional basName As String = "basFunction") As String
   Dim TmpStr As String
   TmpStr = basName & " = 0, 0, 0, 0, C" & vbCrLf
   TmpStr = TmpStr & "frmMain = 0, 0, 0, 0,"
   TmpStr = TmpStr & " C, 22, 25, 864, 475, C" & vbCrLf
   VBVBW = TmpStr
End Function

'basFunction.bas
Public Function VBbas(Optional basName As String = "basFunction") As String
   Dim TmpStr As String
   TmpStr = "Attribute VB_Name = " & Chr(34) & basName & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Option Explicit"
   TmpStr = TmpStr & vbCrLf
   VBbas = TmpStr
End Function


'=================================================================================
'============================= ActiveX DLL   =====================================
'Cls文件
Public Function ClsStr_Dll(ClsName As String) As String
   Dim TmpStr As String
   TmpStr = "VERSION 1.0 CLASS" & vbCrLf
   TmpStr = TmpStr & "BEGIN" & vbCrLf
   TmpStr = TmpStr & "  MultiUse = -1  'True" & vbCrLf
   TmpStr = TmpStr & " "
   TmpStr = TmpStr & " Persistable = 0  'NotPersistable" & vbCrLf
   TmpStr = TmpStr & "  DataBindingB"
   TmpStr = TmpStr & "ehavior = 0  'vbNone" & vbCrLf
   TmpStr = TmpStr & "  DataSourceBehavior  = 0  '"
   TmpStr = TmpStr & "vbNone" & vbCrLf
   TmpStr = TmpStr & "  MTSTransactionMode  = 0  'NotAnMTSObject"
   TmpStr = TmpStr & vbCrLf
   TmpStr = TmpStr & "END" & vbCrLf
   TmpStr = TmpStr & "Attribute VB_Name = " & Chr(34) & ClsName & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Attribut"
   TmpStr = TmpStr & "e VB_GlobalNameSpace = False" & vbCrLf
   TmpStr = TmpStr & "Attribute VB_Creatab"
   TmpStr = TmpStr & "le = True" & vbCrLf
   TmpStr = TmpStr & "Attribute VB_PredeclaredId = False" & vbCrLf
   TmpStr = TmpStr & "Att"
   TmpStr = TmpStr & "ribute VB_Exposed = True" & vbCrLf
   TmpStr = TmpStr & "Option Explicit" & vbCrLf
   TmpStr = TmpStr & vbCrLf
   ClsStr_Dll = TmpStr
End Function

'SCC文件
Public Function SCCstr_DLL(ProjectName As String) As String
   Dim TmpStr As String
   TmpStr = "[SCC]" & vbCrLf
   TmpStr = TmpStr & "SCC=This is a source code control file" & vbCrLf
   TmpStr = TmpStr & "[" & ProjectName & "."
   TmpStr = TmpStr & "vbp]" & vbCrLf
   TmpStr = TmpStr & "SCC_Project_Name=this project "
   TmpStr = TmpStr & "is not under source code control" & vbCrLf
   TmpStr = TmpStr & "SCC_Aux_Path=<Th"
   TmpStr = TmpStr & "is is an empty string for the mssccprj.scc file>" & vbCrLf
   SCCstr_DLL = TmpStr
End Function

'dll工程名
Public Function ProjectStr_DLL(ClsName As String, basName As String, ProjectName As String) As String
   Dim TmpStr As String
   TmpStr = "Type=OleDll" & vbCrLf
   TmpStr = TmpStr & "Class=" & ClsName & "; " & ClsName & ".cls" & vbCrLf
   TmpStr = TmpStr & "R"
   TmpStr = TmpStr & "eference=*\G{00020430-0000-0000-C000-000000000046}"
   TmpStr = TmpStr & "#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automat"
   TmpStr = TmpStr & "ion" & vbCrLf
   TmpStr = TmpStr & "Module=" & basName & "; " & basName & ".bas" & vbCrLf
   TmpStr = TmpStr & "Startup="
   TmpStr = TmpStr & Chr(34) & "(None)" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Command32=" & Chr(34) & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Name=" & Chr(34) & ProjectName & Chr(34) & vbCrLf
   TmpStr = TmpStr & "He"
   TmpStr = TmpStr & "lpContextID=" & Chr(34) & "0" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "CompatibleMode=" & Chr(34) & "1" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "MajorVer=1" & vbCrLf
   TmpStr = TmpStr & "M"
   TmpStr = TmpStr & "inorVer=0" & vbCrLf
   TmpStr = TmpStr & "RevisionVer=0" & vbCrLf
   TmpStr = TmpStr & "AutoIncrementVer=0" & vbCrLf
   TmpStr = TmpStr & "Serv"
   TmpStr = TmpStr & "erSupportFiles=0" & vbCrLf
   TmpStr = TmpStr & "VersionCompanyName=" & Chr(34) & "微软中国" & Chr(34) & vbCrLf
   TmpStr = TmpStr & "Compi"
   TmpStr = TmpStr & "lationType=0" & vbCrLf
   TmpStr = TmpStr & "OptimizationType=0" & vbCrLf
   TmpStr = TmpStr & "FavorPentiumPro("
   TmpStr = TmpStr & "tm)=0" & vbCrLf
   TmpStr = TmpStr & "CodeViewDebugInfo=0" & vbCrLf
   TmpStr = TmpStr & "NoAliasing=0" & vbCrLf
   TmpStr = TmpStr & "BoundsCh"
   TmpStr = TmpStr & "eck=0" & vbCrLf
   TmpStr = TmpStr & "OverflowCheck=0" & vbCrLf
   TmpStr = TmpStr & "FlPointCheck=0" & vbCrLf
   TmpStr = TmpStr & "FDIVCheck="
   TmpStr = TmpStr & "0" & vbCrLf
   TmpStr = TmpStr & "UnroundedFP=0" & vbCrLf
   TmpStr = TmpStr & "StartMode=1" & vbCrLf
   TmpStr = TmpStr & "Unattended=0" & vbCrLf
   TmpStr = TmpStr & "Retai"
   TmpStr = TmpStr & "ned=0" & vbCrLf
   TmpStr = TmpStr & "ThreadPerObject=0" & vbCrLf
   TmpStr = TmpStr & "MaxNumberOfThreads=1" & vbCrLf
   TmpStr = TmpStr & "Th"
   TmpStr = TmpStr & "readingModel=1" & vbCrLf
   TmpStr = TmpStr & vbCrLf
   TmpStr = TmpStr & "[MS Transaction Server]" & vbCrLf
   TmpStr = TmpStr & "AutoRef"
   TmpStr = TmpStr & "resh=1" & vbCrLf
   ProjectStr_DLL = TmpStr
End Function



'*********************************8*********8****
'** 名称:GetFilePath
'** 功能:获取路径
'** 参数:
'** 返:
'** 用法;
'************************************************
Public Function GetFilePath(FullFileName As String) As String
   Dim TmpArr() As String
   Dim TmpStr As String
   Dim tmpFileName As String
   TmpArr = Split(FullFileName, "\", -1, vbTextCompare)
   If UBound(TmpArr) > 0 Then
      tmpFileName = TmpArr(UBound(TmpArr))
      TmpArr(UBound(TmpArr)) = ""
      GetFilePath = Join(TmpArr, "\")
   Else
      GetFilePath = ""
   End If
End Function