WIS blogg

Fant fort ut at en kunne laste ned vanlig fil med denne koden fra www.cpearson.com

Option Explicit
Option Compare Text

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modDownloadFile
' By Chip Pearson, chip@cpearson.com, www.cpearson.com/Excel/DownloadFile.aspx
' Date: 23-April-2003
' This module contains the DownloadFile function and supporting players to
' download a file from a URL to a local file name.
'
' Example Usage:
'
'        Dim URL As String
'        Dim LocalFileName As String
'        Dim B As Boolean
'        Dim ErrorText As String
'
'        URL = "http://www.cpearson.com/Zips/FindAll.zip"
'        LocalFileName = "C:\Test\FindAll.zip"
'        B = DownloadFile(UrlFileName:=URL, _
'                        DestinationFileName:=LocalFileName, _
'                        Overwrite:=OverwriteRecycle, _
'                        ErrorText:=ErrorText)
'        If B = True Then
'            Debug.Print "Download successful"
'        Else
'            Debug.Print "Download unsuccessful: " & ErrorText
'        End If
'
' The Overwrite parameter of DownloadFile indicates how to handle the
' case when LocalFileName already exists. It is one of the following
' values:
'        OverwriteKill      use Kill to delete the existing file.
'        OverwriteRecycle   send the existing file to the Recycle Bin.
'        DoNotOverwrite     do not overwrite and terminate the procedure.
'        PromptUser         prompt the user asking whether to overwrite file.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Enum DownloadFileDisposition
    OverwriteKill = 0
    OverwriteRecycle = 1
    DoNotOverwrite = 2
    PromptUser = 3
End Enum

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API functions, constants,and types.
' Used for RecycleFile.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
    "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" _
    Alias "PathIsNetworkPathA" ( _
    ByVal pszPath As String) As Long

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

Private Declare Function SHEmptyRecycleBin _
    Lib "shell32" Alias "SHEmptyRecycleBinA" _
    (ByVal hwnd As Long, _
     ByVal pszRootPath As String, _
     ByVal dwFlags As Long) As Long

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const MAX_PATH As Long = 260

Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type

'''''''''''''''''''''''''''
' Download API function.
''''''''''''''''''''''''''''''''''''''
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
                        "URLDownloadToFileA" ( _
                            ByVal pCaller As Long, _
                            ByVal szURL As String, _
                            ByVal szFileName As String, _
                            ByVal dwReserved As Long, _
                            ByVal lpfnCB As Long) As Long



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DownloadFile
' This downloads a file from a URL to a local filename.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DownloadFile(UrlFileName As String, _
                            DestinationFileName As String, _
                            Overwrite As DownloadFileDisposition, _
                            ErrorText As String) As Boolean

Dim Disp As DownloadFileDisposition
Dim Res As VbMsgBoxResult
Dim B As Boolean
Dim S As String
Dim L As Long

ErrorText = vbNullString

If Dir(DestinationFileName, vbNormal) <> vbNullString Then
    Select Case Overwrite
        Case OverwriteKill
            On Error Resume Next
            Err.Clear
            Kill DestinationFileName
            If Err.Number <> 0 Then
                ErrorText = "Error Kill'ing file '" & DestinationFileName & "'." & vbCrLf & Err.Description
                DownloadFile = False
                Exit Function
            End If
    
        Case OverwriteRecycle
            On Error Resume Next
            Err.Clear
            B = RecycleFileOrFolder(DestinationFileName)
            If B = False Then
                ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
                DownloadFile = False
                Exit Function
            End If
        
        Case DoNotOverwrite
            DownloadFile = False
            ErrorText = "File '" & DestinationFileName & "' exists and disposition is set to DoNotOverwrite."
            Exit Function
            
        'Case PromptUser
        Case Else
            S = "The destination file '" & DestinationFileName & "' already exists." & vbCrLf & _
                "Do you want to overwrite the existing file?"
            Res = MsgBox(S, vbYesNo, "Download File")
            If Res = vbNo Then
                ErrorText = "User selected not to overwrite existing file."
                DownloadFile = False
                Exit Function
            End If
            B = RecycleFileOrFolder(DestinationFileName)
            If B = False Then
                ErrorText = "Error Recycle'ing file '" & DestinationFileName & "." & vbCrLf & Err.Description
                DownloadFile = False
                Exit Function
            End If
    End Select
End If

L = URLDownloadToFile(0&, UrlFileName, DestinationFileName, 0&, 0&)
If L = 0 Then
    DownloadFile = True
Else
    ErrorText = "Buffer length invalid or not enough memory."
    DownloadFile = False
End If
    
End Function
                            
Private Function RecycleFileOrFolder(FileSpec As String) As Boolean

    Dim FileOperation As SHFILEOPSTRUCT
    Dim lReturn As Long

    If (Dir(FileSpec, vbNormal) = vbNullString) And _
        (Dir(FileSpec, vbDirectory) = vbNullString) Then
        RecycleFileOrFolder = True
        Exit Function
    End If

    With FileOperation
        .wFunc = FO_DELETE
        .pFrom = FileSpec
        .fFlags = FOF_ALLOWUNDO
		' Or
        .fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
    End With

    lReturn = SHFileOperation(FileOperation)
    If lReturn = 0 Then
        RecycleFileOrFolder = True
    Else
        RecycleFileOrFolder = False
    End If
End Function

        
        

Men ingen enkel måte og laste ned en passordbeskyttet fil:-(

Løsningen er snublende nær, det er bare og laste ned med url'en: http://brukernavn:passord@site.no

Ove B-)

I ett prosjekt så hadde vi behov for å poste en url. Problemet var bare at æøå rotet til alt på serversiden, og vi fikk ikke ut parametrene.

Etter litt googling så fant vi fort diverse varianter av UrlEncode, deriblandt en versjon som skulle støtte UTF-8:

http://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba

Men vi kom ikke helt i mål, for vi fikk ikke konverteringen til UTF-8 til å virke:-( Nytt dykk i google kom opp med:

http://www.codenewsgroups.net/vb/t13396-widechartomultibyte-utf-8.aspx

I en god del access prosjekt så benytter vi to databaser, en front og en database.

Problemet er ofte at databasene får forskjellig sti hos oss og hos kunden. Noe som gjør at en må knytte opp tabellene på nytt.

Tidligere benyttet vi denne koden:

  For Each Tdf In CurrentDb.TableDefs
    If Tdf.Connect <> "" Then
      strTable = Tdf.Name
      CurrentDb.TableDefs(strTable).Connect = ";DATABASE=<sti>\<backenddb>.mdb"
      CurrentDb.TableDefs(strTable).RefreshLink '(Denne gir feilmelding)
    End If
  Next

Men den feiler nå på .RefreshLink, og feilen er at en ikke får satt .Connect til ny sti.

Løsningen var og slette koblingen og opprette den på nytt:

  For Each Tdf In CurrentDb.TableDefs
    If Tdf.Connect <> "" Then
      strTable = Tdf.Name
      CurrentDb.TableDefs.Delete strTable
      Set td = CurrentDb.CreateTableDef(strTable, dbAttachSavePWD, strTable, ";DATABASE=<sti>\<backenddb>.mdb")
      CurrentDb.TableDefs.Append td
    End If
  Next

Ove B-)

Eller: Hvordan konvertere phpBB til ren HTML i Access VBA

"Om du er en seriøs programmerer så bør RegExp sitte i fingertuppene"

Hørt noe tilsvarende?

Vel, fikk i oppgave her forleden og konvertere ett phpBB-forum til ren HTML, og jeg er ikke en racer på RegExp.

Og en skal ikke ta store dykket i RegExp før en skjønner hvorfor RegExp er TESTEN for en programmerer.

Men det skal heller ikke store dykket til for å løse så enkle oppgaver som phpBB2HTML.

Her er det du trenger for å løse enkle oppgaver i RegExp:

1. .* - matcher alle tegn

2. .*? - matcher alle tegn, men er ikke grådig, så den stopper ved første forekomst

3. (.*?) treffer det samme som .*? men forskjellen er at når du plasserer søket i () så kan du bruke treffet i strengen du skal erstatte med. Første forekomst av (.*?) tilsvarer $1 i resultat strengen.

4. \ - lar deg søke etter spesialtegn.

Eksempel:

Oppgaven er og konvertere:

[url=http://wikipedia.org]Wikipedia[/url]

til:

<a href="http://wikipedia.org">Wikipedia</a>

Løsning:

  Regex.Pattern = "\[url\=(.*?)\](.*?)\[/url.*?\]"
  str = Regex.Replace(str, "<a href=$1>$2</a>")

Forklaring:

\[url\=   matcher   [url=

så må vi ta vare på adressen:

(.*?)    matcher   "http://wikipedia.org"   og tar vare på det som matcher i variablen $1

\]   matcher   første ]

(.*?)   matcher   Wikipedia   og tar vare på det som matcher i variablen $2

\[/url.*?\]   matcher   [/url]   .*? er tatt med pga at enkelte tager hadde en id i seg: [/url:9878998]

Hele strengen som matcher blir så erstattet med "<a href=$1>$2</a>  der $1 = "http://wikipedia.org" og $2 = Wikipedia

Så slutt resultatet blir: <a href="http://wikipedia.org">Wikipedia</a>

Dette ble en veldig kort og overfladisk innføring i regulære uttrykk, men forhåpentlig nok til å fange interessen og inspirere til dypere dykk.

Snorkling i regexp: Microsofts korte innføring i VBA's RegExp

Dypdykking: regular-expressions.info

For lettere kunne teste ut dine regulære uttrykk så anbefaler jeg RegExTester eller Rubular

'VBA funksjonen slik den ble til slutt

Public Function phpBB2HTML(str) As String ' Konverter PHPBB kode til html-kode

  'Sjekk om vi har innparameter
  If IsNull(str) Then
    FBB = ""
    Exit Function
  End If

  Dim oRegExp As Object
  Set Regex = CreateObject("VBScript.RegExp")
  With Regex
    .Global = True
    .IgnoreCase = True
    .MultiLine = True
  End With
  '[url]
  Regex.Pattern = "\[url\](.*?)\[/url.*?\]"
  str = Regex.Replace(str, "<a href=""$1"">$1</a>")
  Regex.Pattern = "\[url\=(.*?)\](.*?)\[/url.*?\]"
  str = Regex.Replace(str, "<a href=""$1"">$2</a>")
  '[img]
  Regex.Pattern = "\[img\](.*?)\[/img.*?\]"
  str = Regex.Replace(str, "<img src=""$1"">")
  '[size=15:987327837]
  Regex.Pattern = "\[size\=(.*?):.*?\]"
  str = Regex.Replace(str, "<span style=""font-size:$1px"">")
  Regex.Pattern = "\[\/size.*?\]"
  str = Regex.Replace(str, "</p></span>")
  '[color=#FF0000]Red Text[/color]
  Regex.Pattern = "\[color\=(.*?)\]"
  str = Regex.Replace(str, "<span style=""color:$1"">")
  Regex.Pattern = "\[\/color.*?\]"
  str = Regex.Replace(str, "</p></span>")
  '[quote]
  Regex.Pattern = "\[quote.*?\]"
  str = Regex.Replace(str, "<blockquote><p>")
  Regex.Pattern = "\[\/quote.*?\]"
  str = Regex.Replace(str, "</p></blockquote>")
  '[code]
  Regex.Pattern = "\[code.*?\]"
  str = Regex.Replace(str, "<pre>")
  Regex.Pattern = "\[\/code.*?\]"
  str = Regex.Replace(str, "</pre>")
  '[b]
  Regex.Pattern = "\[b.*?\]"
  str = Regex.Replace(str, "<b>")
  Regex.Pattern = "\[\/b.*?\]"
  str = Regex.Replace(str, "</b>")
  '[i]
  Regex.Pattern = "\[i.*?\]"
  str = Regex.Replace(str, "<i>")
  Regex.Pattern = "\[\/i.*?\]"
  str = Regex.Replace(str, "</i>")
  '[u]
  Regex.Pattern = "\[u.*?\]"
  str = Regex.Replace(str, "<u>")
  Regex.Pattern = "\[\/u.*?\]"
  str = Regex.Replace(str, "</u>")
  '[list]
  Regex.Pattern = "\[list.*?\]"
  str = Regex.Replace(str, "")
  Regex.Pattern = "\[\/list.*?\]"
  str = Regex.Replace(str, "")
  'linjeskift
  str = Replace(str, vbCrLf, "<br>")
  
  FBB = str
  
  Set Regex = Nothing

End Function

Ett lite hint til slutt i forbindelse med phpBB konvertering, og det er at datoer blir i MySql lagret som sekunder etter 1970-01-01 00:00:00. Dvs for å få frem korrekt dato så må en bruke funksjonen DateAdd("s", dato, "1970-01-01 00:00:00")

Mvh

Ove B-)

Har ved mange anledninger kunne tenkt meg å overvåke mapper eller filer for endringer i Access.

I forbindelse med at vi ønsket ekstern editor for tekstbokser i Access så satte jeg meg ned og googlet til jeg fant løsningen i:

The access webs: File Change Notification Component

 Som i følge nettsiden lar deg: 

I vår Access applikasjon ønsket vi som sagt og redigere tekst i en tekstboks i ekstern editor. Løsningen ble å lagre innholdet i tekstboksen til en tekstfil i en mappe som jeg overvåker.

Når jeg så åpner ekstern editor(PSPad) med tekstfilen og lagrer så vil jeg kunne fange opp det i Access og hente inn teksten fra den endrede filen og oppdatere tekstboksen.

Ett par ting som er verdt og nevne:

1. Legg til dll'en i VBA editoren Tools - References

2. Koden som starter overvåkningen kan ikke legges på ett skjemas onOpen, fordi eksekveringen vil ikke gå videre etter Call clsFCN.StartWatch. Løsningen var og legge koden på skjemaets timer.

Resultatet ble denne lille demo databasen:

FilMonitorering.zip

VBA koden er i hovedsak knabbet fra VB eksemplet som fulgte med komponenten.

For å teste så må du først laste ned FileChangeNotificationComponent og registrere dll-en som følger med.

Pakk så ut filene i FilMonitorering.zip i en egen mappe, start opp FilMonitorering.mdb, rediger fila RedigerMeg.txt, lagre og se hva som skjer i Access:-)

mvh

Ove B-)

Access/VBA har ingen funksjoner eller prosedyrer som lar deg jobbe med utklippstavlen.

Etter litt googling fant jeg denne løsningen på http://www.cpearson.com/excel/clipboard.htm:

I VBA editoren, gå til Tools - References og legg til referanse til Microsoft Forms 2.0

Finner du ikke Microsoft Forms 2.0 i listen, så velg Browse og bla deg frem til FM20.dll som ligger i C:\windows\system32

Trikset er og gå via DataObject:

Kopiere til utklippstavla:

Dim MyDataObj As New DataObject

MyDataObj.SetText  "Dette skal på utklippstavla..."  'Lagrer tekst i MyDataObj som i neste omgang havner på Utklippstavla
MyDataObj.PutInClipboard

Kopiere fra utklippstavla:

MyDataObj.GetFromClipboard

Dim strUtklippstavla as String

strUtklippstavla = MyDataObj.GetText

Ut fra dette så kan vi lage følgende prosedyrer:

Public Sub PutOnClipboard(str as String)
    Dim MyDataObj As New DataObject
    MyDataObj.SetText str
    MyDataObj.PutInClipboard
End Sub

Public Function GetOffClipboard() As String
    Dim MyDataObj As New DataObject
    MyDataObj.GetFromClipboard
    GetOffClipboard = MyDataObj.GetText()
End Function

Public Sub ClearClipboard()
    Dim MyDataObj As New DataObject
    MyDataObj.SetText ""
    MyDataObj.PutInClipboard
End Sub

 Ove B-)

Merkelig nok så mangler Access VBA Week()

Men løsningen ligger snublende nær:

Week(Now()) = Format(Now(),"ww",vbMonday,vbFirstFourDays)

eller

Week(Now() = Datepart("ww",Now(),2,2)

De siste to parametrene sørger for at vi får uketall etter norsk regnemåte.

Ove B-)