Intermittent vba code need advice

[Directlinq]

I am a complete newbie at vb but i have bodged together some code that does what i want. The only thing is it sometimes works and sometimes does not. I think i have narrowed it down to the problem of it not successfully adding a record to an sql linked table (sometimes).

Can i post my whole code and ask for some friendly advise for improvments to what i have done.

I thought i would ask first incase im not allowed

Many Thanks

Thank you here it is

Option Compare Database
 
Private Declare Function SHFileOperation Lib "shell32.dll" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
        hwnd As Long
        wFunc As Long
        pFrom As String
        pTo As String
        fFlags As Integer
        fAnyOperationsAborted As Long
        hNameMappings As Long
        lpszProgressTitle As String
End Type
 
Private Const FOF_CREATEPROGRESSDLG = &H0
Private Const FO_COPY = 2
 
Private Function AllFiles(ByVal FullPath As String) _
  As String()
Dim oFs As New FileSystemObject
Dim sAns() As String
Dim oFolder As Folder
Dim oFile As File
Dim lElement As Long
Dim blank As String
blank = "1"
ReDim sAns(0) As String
If oFs.FolderExists(FullPath) Then
    Set oFolder = oFs.GetFolder(FullPath)
 
    For Each oFile In oFolder.Files
      lElement = IIf(sAns(0) = "", 0, lElement + 1)
      ReDim Preserve sAns(lElement) As String
      sAns(lElement) = oFile.Name
    Next
End If
AllFiles = sAns
ErrHandler:
    Set oFs = Nothing
    Set oFolder = Nothing
    Set oFile = Nothing
End Function
 
Private Sub Command0_Click()
Dim artist As String
Dim nFileNum As Integer, sText As String, sNextLine As String, lLineCount As Long
 
Dim strData() As String
Dim dupeinvid As String
Dim vididmax As String
Dim dtan As Variant
Dim filename As Variant
Dim SH As SHFILEOPSTRUCT
Dim StrSQL As String
 
KillFolder ("E:\MEDIA")
'''' creating folders
CreateFolder ("E:\MEDIA\Burn Folder\Music List")
CreateFolder ("E:\MEDIA\Burn Folder\Database")
CreateFolder ("E:\MEDIA\Temp Folder")
CreateFolder ("E:\MEDIA\Songs Already Exist")
 
'==================================
Answer = MsgBox("Please Put The Music Video DVD in the drive and press ok", vbYesNo + vbExclamation + vbDefaultButton2, "Is DVD in Drive?")
If Answer = vbYes Then
'Copy all mpeg  files from dvd to temp folder
    With SH
       .fFlags = FOF_CREATEPROGRESSDLG 'flag for progressbar
       .wFunc = FO_COPY  'to copy
        .pFrom = "D:\*.MPG" 'source
        .pTo = "E:\MEDIA\Temp Folder"
    End With
 
    Call SHFileOperation(SH)
GoTo readfolder
End If
Exit Sub
readfolder:
Dim sFiles() As String
Dim lCtr As Long
sFiles = AllFiles("E:\MEDIA\Temp Folder")
For lCtr = 0 To UBound(sFiles)
Open "E:\MEDIA\New Video.txt" For Append As #7
Print #7, sFiles(lCtr)
Close #7
Next
 
 
nFileNum = FreeFile
Dim filenametemp As String
' Open a text file for input. inputbox returns the path to read the file
Open "E:\MEDIA\New Video.txt" For Input As nFileNum
lLineCount = 1
' Read the contents of the file
Do While Not EOF(nFileNum)
   Line Input #nFileNum, sNextLine
   sText = sNextLine
filenametemp = sNextLine
strData() = Split(sText, IIf(InStr(1, sNextLine, "–") > 0, "–", "-"), , vbTextCompare)
Dim space As Integer
 
artist = Trim(strData(0))
space = InStr(artist, " ")
artist = Right(artist, Len(artist) - space)
songname = Trim(strData(1))
songname = Replace(songname, ".mpg", "")
If IsNull(DLookup("[artist_name]", "[dbo_tblArtist]", "[artist_name]=""" & artist & """")) = False Then
artistid = DLookup("[artist_id]", "[dbo_tblArtist]", "[artist_name] =""" & artist & """")
 
 
Dim DB As DAO.Database, rs As DAO.Recordset
Set DB = CurrentDb()
Set rs = CurrentDb.OpenRecordset("SELECT artist_id " & "FROM dbo_tblVideo " & "WHERE artist_id = " & artistid & " " & "AND Name = '" & songname & "'")
If rs.RecordCount <> 0 Then
 
 
 
 
Kill "E:\MEDIA\Temp Folder\" & filenametemp
GoTo nextline:
End If
 
DoCmd.OpenForm "Form2", WindowMode:=acDialog
 
vididmax = Nz(DMax("video_id", "dbo_tblVideo"))
dtan = DLookup("[dtan_lib_no]", "[dbo_tblVideo]", "video_id=" & vididmax & "")
dtan = Replace(dtan, "VDT", "")
dtan = dtan + 1
dtan = "VDT" & Format(dtan, "000000")
filename = Format(dtan, "000000") & ".MPG"
 
 
'ADDing TO VIDEO TABLE HERE
 
Dim Msg As String
Set DB = CurrentDb
CurrentDb.Execute "INSERT INTO  dbo_tblVideo(video_id,artist_id,media_type_id,genre_id,Category_id,emotion_id,filename,Name,Description,Year,profile_id,volume_level,date_created,cue_in,fade_out,dtan_lib_no,rating,ext_path,video_length)" & "VALUES('" & Nz(DMax("video_id", "dbo_tblVideo") + 1) & "','" & artistid & "',3,'" & genreid & "','" & categoryid & "','','" & filename & "','" & songname & "','','" & Year(Date) & "',1,0,'" & Date & " " & Time & "',0,0,'" & dtan & "','','',''); "
Name "E:\MEDIA\Temp Folder\" & filenametemp As "E:\MEDIA\Burn Folder\" & filename
Open "E:\MEDIA\Burn Folder\Music List\New Video Printout.txt" For Append As #4
Print #4, artist & " - " & songname
Close #4
GoTo nextline
 
Exit Sub
  Else
 
'Adding artist to table
 
Dim aid As String
aid = Nz(DMax("artist_id", "dbo_tblArtist") + 1)
Dim rst As New ADODB.Recordset
rst.Open "dbo_tblArtist", CurrentProject.Connection, adOpenStatic
sSQL = "INSERT INTO dbo_tblArtist (artist_id,artist_name,artist_description,image_filename) " & "VALUES ('" & aid & "' ,'" & artist & "' ,'',''); "
CurrentDb.Execute sSQL
rst.Close
Set rst = Nothing
Set objConn = Nothing
artistid = DLookup("[artist_id]", "[dbo_tblArtist]", "[artist_name] =""" & artist & """")
End If
 
 
DoCmd.OpenForm "Form2", WindowMode:=acDialog
 
vididmax = Nz(DMax("video_id", "dbo_tblVideo"))
dtan = DLookup("[dtan_lib_no]", "[dbo_tblVideo]", "video_id=" & vididmax & "")
dtan = Replace(dtan, "VDT", "")
dtan = dtan + 1
dtan = "VDT" & Format(dtan, "000000")
filename = Format(dtan, "000000") & ".MPG"
 
'ADD SONGNAME TO VIDEO TABLE
 
Set DB = CurrentDb
CurrentDb.Execute "INSERT INTO dbo_tblVideo (video_id,artist_id,media_type_id,genre_id,Category_id,emotion_id,filename,Name,Description,Year,profile_id,volume_level,date_created,cue_in,fade_out,dtan_lib_no,rating,ext_path,video_length)" & "VALUES('" & Nz(DMax("video_id", "dbo_tblVideo") + 1) & "','" & artistid & "',3,'" & genreid & "','" & categoryid & "','','" & filename & "','" & songname & "','','" & Year(Date) & "',1,0,'" & Date & " " & Time & "',0,0,'" & dtan & "','','',''); "
 
Name "E:\MEDIA\Temp Folder\" & filenametemp As "E:\MEDIA\Burn Folder\" & filename
Open "E:\MEDIA\Burn Folder\Music List\New Video Printout.txt" For Append As #4
Print #4, artist & " - " & songname
Close #4
nextline:
Loop
 
Close nFileNum
DoCmd.Quit
End Sub
 
Private Sub Command3_Click()
DoCmd.Quit
End Sub
 
Private Sub Form_Open(Cancel As Integer)
DoCmd.Maximize
End Sub

 

[boblarson]

Yes, but please use the code tags.

See this example on how to type them around your code:

 

[MarkK]

My friendly advice is tidy up your code. Write shorter procedures; write subs or functions that do ONE thing. Then you look at one routine and you know at a glance what it does. See if it calls another routine? If so find that routine and know at a glance what that does. This will take extra time at first, and then it'll save you hours and hours and hours.

Private Sub SomeSub
   IF code is tidy and blocks indented Then
      Code is easier to understand and maintain,
      Saving you time and headaches
   Else
      Do While code is messy
         Scratch Head
         Look for bugs
         Seek help
      Loop
   End If
End Sub

And if you've indented 3 or 4 times you need subroutines...

Private Sub SomeSub
   IF code is tidy and blocks indented Then
      DefineAdvantages
   Else
      HandleMessyCode
   End If
End Sub

Sub DefineAdvantages
   Code is easier to understand and maintain,
   Saving you time and headaches
End Sub

Sub HandleMessyCode
   Do While code is messy
      Scratch Head
      Look for bugs
      Seek help
   Loop
End Sub

Simple well named subroutines make code simpler to understand. Bugs will find it harder to get a foothold. Errors will be localized and specific so you can find them and solve them.
I bet you any money that if you apply this process to your code, you'll find the problem AND I bet you'll find another problem that hasn't happened yet.